vfile_relmgr_.alm 08/15/86 1556.1rew 08/15/86 1436.6 27621 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " *********************************************************** " HISTORY COMMENTS: " 1) change(86-06-13,Dupuis), approve(86-08-05,MCR7491), " audit(86-08-08,Blair), install(86-08-15,MR12.0-1127): " Made available so that an unbound version of mrds could be created " easily. (phx20405, mrds #157) " END HISTORY COMMENTS " " "82-08-19 Roger Lackey : created "83-03-14 Roger Lackey : added get_tuples_and_ids "83-09-20 Ron Harvey : made get_population an implemented entry " " Macro to generate a call to an external entrypoint in the manager macro ext_transfer segdef &1 &1: getlp tra &2 &end name vfile_relmgr_ ext_transfer close,vrm_close$close ext_transfer create_cursor,vrm_create_cursor$create_cursor ext_transfer create_index,vrm_index$create_index ext_transfer create_MRDS_relation,vrm_create_relation$create_MRDS_relation ext_transfer create_relation,vrm_create_relation$create_relation ext_transfer create_subset_index,vrm_unimplemented_function$return_error_code ext_transfer delete_tuple_by_id,vrm_unimplemented_function$return_error_code ext_transfer delete_tuples_by_id,vrm_delete_by_id$delete_tuples_by_id ext_transfer delete_tuples_by_spec,vrm_unimplemented_function$return_error_code ext_transfer destroy_cursor,vrm_destroy_cursor$destroy_cursor ext_transfer destroy_index,vrm_index$destroy_index ext_transfer destroy_relation_by_opening,vrm_destroy_relation$destroy_relation_by_opening ext_transfer destroy_relation_by_path,vrm_destroy_relation$destroy_relation_by_path ext_transfer get_count,vrm_get_by_spec$get_count ext_transfer get_description,vrm_get_description$get_description ext_transfer get_duplicate_key_count,vrm_get_duplicate_key_count$get_duplicate_key_count ext_transfer get_max_and_min_attrs,vrm_unimplemented_function$return_error_code ext_transfer get_open_relations,vrm_open_man$get_open_relations ext_transfer get_population,vrm_get_population$get_population ext_transfer get_tuple_by_id,vrm_get_by_id$get_tuple_by_id ext_transfer get_tuple_id,vrm_get_by_spec$get_tuple_id ext_transfer get_tuples_by_id,vrm_get_by_id$get_tuples_by_id ext_transfer get_tuples_by_spec,vrm_get_by_spec$get_tuples_by_spec ext_transfer get_tuples_and_ids,vrm_get_by_spec$get_tuples_and_ids ext_transfer metering_on,vrm_create_cursor$metering_on ext_transfer metering_off,vrm_create_cursor$metering_off ext_transfer modify_tuple_by_id,vrm_unimplemented_function$return_error_code ext_transfer modify_tuples_by_id,vrm_modify_by_id$modify_tuples_by_id ext_transfer modify_tuples_by_spec,vrm_unimplemented_function$return_error_code ext_transfer open,vrm_open$open ext_transfer put_tuple,vrm_put$put_tuple ext_transfer put_tuples,vrm_put$put_tuples ext_transfer set_scope,vrm_set_scope$set_scope end  vrm_close.pl1 11/23/84 0800.9rew 11/21/84 0920.1 30600 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ vrm_close: close: proc (I_rel_opening_id, O_code); /* BEGIN_DESCRIPTION . Close the opening for a relation. Free any storage associated with the opening. * END_DESCRIPTION */ /* History: 82-08-20 R. Harvey: Initially written 82-11-03 R. Harvey: Modified for open_info structure 84-05-25 B. G. Moberg: Modified to not free the same structure twice */ /* Parameters */ dcl I_rel_opening_id bit (36) aligned; dcl O_code fixed bin (35); call vrm_open_man$get_open_info_ptr (I_rel_opening_id, vrm_open_info_ptr, O_code); if O_code = 0 then do; vrm_open_info.number_of_openings = vrm_open_info.number_of_openings - 1; if vrm_open_info.number_of_openings < 1 then do; vrm_com_ptr = vrm_open_info.com_ptr; call vrm_open_man$remove_opening (vrm_open_info.opening_id); call free_open_info (vrm_open_info_ptr); end; end; return; release_open_info: entry (I_vrm_open_info_ptr); dcl I_vrm_open_info_ptr ptr parameter; call free_open_info (I_vrm_open_info_ptr); return; %page; free_open_info: proc (I_voi_ptr); dcl I_voi_ptr ptr parameter; dcl i fixed bin; vrm_open_info_ptr = I_voi_ptr; if vrm_open_info_ptr ^= null () then do; /* got something to free */ vrm_com_ptr = vrm_open_info.com_ptr; if vrm_open_info.relation_model_ptr -> vrm_rel_desc.switches.MRDS_compatible then do; /* collection_info structure(s) were allocated */ free vrm_open_info.relation_model_ptr -> vrm_rel_desc in (vrm_com.oid_area); /* Although it looks like the next statement should be done, this is never true because primary_key_info_ptr points at the same storage that index_collection (1).info_ptr points at. Therefore, doing this statement results in freeing the same structure twice. This statement is left here, but commented out so that no one will be tempted to add it later if vrm_open_info.primary_key_info_ptr ^= null () then free vrm_open_info.primary_key_info_ptr -> vrm_collection_info in (vrm_com.oid_area); */ do i = 1 to vrm_open_info.number_of_index_collections; if vrm_open_info.index_collection (i).info_ptr ^= null () then free vrm_open_info.index_collection (i).info_ptr -> vrm_collection_info in (vrm_com.oid_area); end; end; /* collection_info structure(s) ... */ call vrmu_iocb_manager$destroy_all_iocbs_for_oid (vrm_open_info_ptr, (0)); free vrm_open_info in (vrm_com.oid_area); end; /* got something to do */ end free_open_info; %page; %include vrm_open_info; %page; %include vrm_collection_info; %page; %include vrm_rel_desc; %page; %include vrm_com; %page; dcl ( addr, fixed, null, rel ) builtin; dcl vrmu_iocb_manager$destroy_all_iocbs_for_oid entry (ptr, fixed bin (35)); dcl vrm_open_man$get_open_info_ptr entry (bit (36) aligned, ptr, fixed bin (35)); dcl vrm_open_man$remove_opening entry (bit (36) aligned); dcl sys_info$max_seg_size fixed bin (35) ext static; end vrm_close;  vrm_create_cursor.pl1 11/23/84 0800.9r w 11/21/84 0933.6 30024 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ vrm_create_cursor: create_cursor: proc (I_rel_opening_id, I_work_area_ptr, O_cursor_ptr, O_code); /* . BEGIN_DESCRIPTION Allocate aand inititialize a cursor in the work_area. . END_DESCRIPTION */ /* History 82-08-19 R. Harvey: Initially written 82-12-09 Modified by Roger Lackey : To added vrm_iocb_list_block handling 83-05-26 Modified Roger Lackey : To conform to relation curdor sepcification 83-06-21 Roger Lackey : Added secondary_iocb_ptr to vrm_cursor */ %page; /* Parameters */ dcl I_rel_opening_id bit (36) aligned; dcl I_work_area_ptr ptr; dcl O_cursor_ptr ptr; dcl O_code fixed bin (35); call vrm_open_man$get_open_info_ptr (I_rel_opening_id, vrm_open_info_ptr, code); if code ^= 0 then call error (code); vrm_rel_desc_ptr = vrm_open_info.relation_model_ptr; work_area_ptr = I_work_area_ptr; allocate vrm_cursor in (work_area) set (vrm_cursor_ptr); vrm_cursor.opening_id = I_rel_opening_id; string (vrm_cursor.debug_sw) = "0"b; string (vrm_cursor.switches) = "0"b; vrm_cursor.open_info_ptr = vrm_open_info_ptr; vrm_cursor.vrm_relation_desc_ptr = vrm_rel_desc_ptr; vrm_cursor.iocb_ptr = null (); /* Do this for cleanup */ vrm_cursor.secondary_iocb_ptr = null (); /* Do this for cleanup */ vrm_cursor.search_list_ptr = null; vrm_cursor.search_keys_ptr = null; vrm_cursor.vrm_iocb_list_block_ptr = null; vrm_cursor.vrm_iocb_list_block_iocbs_ix = 0; call vrmu_iocb_manager$add_cursor_iocb (vrm_cursor_ptr, code); if code ^= 0 then call error (code); if metering_sw then do; call vrm_meter$add_meter (vrm_cursor_ptr, vrm_cursor.meter_ptr, code); if code ^= 0 then call error (code); if vrm_cursor.meter_ptr ^= null then do; vrm_cursor.switches.meter_sw = "1"b; vrm_meter_ptr = vrm_cursor.meter_ptr; vrm_meter.switches.metering = "1"b; end; end; else do; vrm_cursor.meter_ptr = null; vrm_cursor.switches.meter_sw = "0"b; end; O_cursor_ptr = vrm_cursor_ptr; O_code = 0; Exit: return; %page; error: proc (ecode); dcl ecode fixed bin (35); O_code = ecode; if vrm_cursor_ptr ^= null () then do; free vrm_cursor; vrm_cursor_ptr = null (); end; goto Exit; end error; metering_on: entry; /* Called by vrm_meter */ metering_sw = "1"b; return; metering_off: entry; /* Called by vrm_meter */ metering_sw = "0"b; return; %page; %include vrm_cursor; %page; %include vrm_open_info; %page; %include vrm_rel_desc; %page; %include vrm_meter; %page; dcl code fixed bin (35); dcl metering_sw bit (1) internal static init ("0"b); dcl null builtin; dcl string builtin; dcl vrmu_iocb_manager$add_cursor_iocb entry (ptr, fixed bin (35)); dcl vrm_meter$add_meter entry (ptr, ptr, fixed bin (35)); dcl vrm_open_man$get_open_info_ptr entry (bit (36) aligned, ptr, fixed bin (35)); dcl work_area area based (work_area_ptr); dcl work_area_ptr ptr; end vrm_create_cursor;  vrm_create_relation.pl1 11/23/84 0800.9r w 11/21/84 0933.6 102852 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ vrm_create_relation: create_relation: proc (I_rel_dir, I_rel_name, I_rel_creation_info_ptr, I_typed_vector_array_ptr, O_rel_opening_id, O_record_collection_id, O_code); /* . BEGIN_DESCRIPTION Create a multi-segment vfile for a database relation. Open the relation and return a collection id. Note that the collection id will always have all bits on. If called at the $create_relation entry, a relation description record will be written to the relation. . END_DESCRIPTON */ /* History: 82-09-27 R. Harvey: Initially written. 82-11-11 R. Harvey: Modified to add internal description record 83-10-04 Roger Lackey : added align_varying_tuple_data procedure to make sure varying part of tuple was word aligned. */ %page; /* vrm_create_relation: proc (I_rel_dir, I_rel_name, I_rel_creation_info_ptr, I_typed_vector_array_ptr, O_rel_opening_id, O_record_collection_id, O_code); */ /* Parameters */ dcl I_rel_dir char (*) parameter; dcl I_rel_name char (*) parameter; dcl I_rel_creation_info_ptr ptr parameter; dcl I_typed_vector_array_ptr ptr parameter; dcl O_rel_opening_id bit (36) aligned parameter; dcl O_record_collection_id bit (36) aligned parameter; dcl O_code fixed bin (35) parameter; MRDS = "0"b; goto common; create_MRDS_relation: entry (I_rel_dir, I_rel_name, I_rel_creation_info_ptr, I_typed_vector_array_ptr, O_rel_opening_id, O_record_collection_id, O_code); MRDS = "1"b; common: O_rel_opening_id = "0"b; O_record_collection_id = "0"b; O_code = 0; iocb_ptr = null (); vrm_rel_desc_ptr = null (); on cleanup call tidy_up; attach_name = unique_chars_ ("0"b) || ".VRM.new_relation"; attach_desc = "vfile_ " || rtrim (I_rel_dir) || ">" || I_rel_name; call iox_$attach_name (attach_name, iocb_ptr, attach_desc, null (), code); if code ^= 0 then call error (code); call iox_$open (iocb_ptr, KSQU, "0"b, code); if code ^= 0 then call error (code); /* Init the vfile */ call iox_$control (iocb_ptr, "record_status", addr (rs_info), code); if code ^= 0 then call error (code); if ^MRDS then do; call iox_$delete_record (iocb_ptr, code); /* trash the zero length record */ if code ^= 0 then call error (code); call create_relation_record; /* put relation info in the relation */ end; call vrm_open (I_rel_dir, I_rel_name, O_rel_opening_id, code); /* Open the relation */ if code ^= 0 then call error (code); O_record_collection_id = "111111111111111111111111111111111111"b; Exit: call tidy_up; return; %page; create_relation_record: proc; typed_vector_array_ptr = I_typed_vector_array_ptr; if typed_vector_array.version ^= TYPED_VECTOR_ARRAY_VERSION_2 then call error (error_table_$unimplemented_version); vrd_no_of_attrs = typed_vector_array.number_of_dimensions; allocate vrm_rel_desc set (vrm_rel_desc_ptr); vrm_rel_desc.record_id = VRM_REL_DESC_RECORD_ID; vrm_rel_desc.version = VRM_REL_DESC_VERSION_1; vrm_rel_desc.file_id = "0000001"b; vrm_rel_desc.rel_id = "000000000001"b; string (vrm_rel_desc.switches) = "0"b; vrm_rel_desc.var_offset = 1; /* bit number for substr */ vrm_rel_desc.maximum_data_length = 0; vrm_rel_desc.number_primary_key_attrs = 0; vrm_rel_desc.number_sec_indexes = 0; vrm_rel_desc.last_var_attr_no = 0; vrm_rel_desc.number_var_attrs = 0; do i = 1 to vrd_no_of_attrs; vrm_attr_info_ptr = addr (vrm_rel_desc.attr (i)); /* get pointer to place to store info */ char_attr_no = i; vrm_attr_info.name = typed_vector_array.dimension_table (i).name; desc_ptr = typed_vector_array.dimension_table (i).descriptor_ptr; vrm_attr_info.descriptor = desc_ptr -> descriptor_bit_36_ovrly; if desc_ptr -> descriptor.type = VARYING_CHAR_TYPE | desc_ptr -> descriptor.type = VARYING_BIT_TYPE then do; /* varying */ vrm_attr_info.varying = "1"b; vrm_rel_desc.switches.stationary_records = "1"b; /* we must do this so records won't move */ vrm_rel_desc.number_var_attrs = vrm_rel_desc.number_var_attrs + 1; /* count the varying attributes */ vrm_rel_desc.last_var_attr_no = i; /* If this is the last... */ end; else vrm_attr_info.varying = "0"b; vrm_attr_info.pad = "0"b; call compute_bit_offset_and_length; end; if vrm_rel_desc.number_var_attrs ^= 0 then call align_varying_tuple_data; /* Align varying part of tuple */ /* convert bit count to char count */ vrm_rel_desc.maximum_data_length = ceil (divide (vrm_rel_desc.maximum_data_length, 9, 21, 5)); rel_size = currentsize (vrm_rel_desc) * 4; /* length of record in bytes */ call iox_$seek_key (iocb_ptr, VRM_REL_DESC_KEY, (0), code); if code = error_table_$no_record then code = 0; if code = 0 then call iox_$write_record (iocb_ptr, vrm_rel_desc_ptr, rel_size, code); if code ^= 0 then call error (code); end create_relation_record; %page; /* * * * * * * * * * * compute_bit_offset_and_length * * * * * * * */ compute_bit_offset_and_length: proc; /* routine to convert the attribute's domain descriptor into the required tuple offset and space required and update the corresponding statistics for the relation information NOTE: the padding routines were introduced to make the data stored in the tuple(via bit offset/length) relect the pl1 definition of storage locations needed for unaligned and aligned data types */ vrm_attr_info.bit_length = vrmu_data_length$get_data_bit_length (desc_ptr -> descriptor_bit_36_ovrly); /* fixed length attribute/domain handling */ if ^vrm_attr_info.varying then do; /* fixed attributes */ padding = vrmu_data_align$align_data_item (desc_ptr, vrm_rel_desc.maximum_data_length); vrm_attr_info.bit_offset = vrm_rel_desc.var_offset + padding; /* set to end of fixed data */ vrm_rel_desc.var_offset = vrm_rel_desc.var_offset + vrm_attr_info.bit_length + padding; /* set new fixed data end */ end; /* varying string handling */ else do; /* varying strings */ vrm_attr_info.bit_offset = vrm_rel_desc.number_var_attrs; /* varying array index, not offset */ padding = pad (WORD, vrm_rel_desc.maximum_data_length); /* varying must start/stop on word boundary */ end; /* set the maximum tuple and key bit lengths */ vrm_rel_desc.maximum_data_length = /* calc in bits for now */ vrm_rel_desc.maximum_data_length + vrm_attr_info.bit_length + padding; end compute_bit_offset_and_length; %page; /* * * * * * * * * * * * * * * pad * * * * * * * * * * * * */ pad: proc (pad_size, pad_base) returns (fixed bin); /* routine to return the number of bits necessary to pad a bit count out to an alignment boundary of 9(byte), 36(word), or 72(double word) bits as determined by the pad size input */ if mod (pad_base, pad_size) = 0 then number_of_bits = 0; else do; number_of_bits = pad_size - mod (pad_base, pad_size); end; return (number_of_bits); dcl pad_size fixed bin; /* either 9 or 36 or 72 */ dcl pad_base fixed bin (35); /* current bit length to be padded */ dcl number_of_bits fixed bin; /* what has to be added to get to the desired boundary */ end pad; %page; align_varying_tuple_data: procedure (); /* varying attributes in the tuple must start on a word boundary, this routine makes sure that the end of the fixed data portion of the tuple, which is where the varying attributes start, is on that boundary */ if vrm_rel_desc.number_var_attrs ^= 0 then do; amount_to_pad = pad (WORD, vrm_rel_desc.var_offset - 1); vrm_rel_desc.var_offset = vrm_rel_desc.var_offset + amount_to_pad; vrm_rel_desc.maximum_data_length = vrm_rel_desc.maximum_data_length + amount_to_pad; end; end align_varying_tuple_data; %page; tidy_up: proc; if iocb_ptr ^= null () then do; call iox_$close (iocb_ptr, code); /* Clean up after ourself */ if code = 0 then call iox_$detach_iocb (iocb_ptr, code); if code = 0 then call iox_$destroy_iocb (iocb_ptr, code); end; if vrm_rel_desc_ptr ^= null () then free vrm_rel_desc; end tidy_up; error: proc (ecode); dcl ecode fixed bin (35); O_code = ecode; go to Exit; end error; %page; %include vrm_rel_desc; %page; %include vu_typed_vector_array; %page; %include mdbm_descriptor; %page; /* Automatic */ dcl attach_name char (40); dcl attach_desc char (210); dcl amount_to_pad fixed bin; /* bits needed for word alignment */ dcl char_attr_no picture "zz9"; dcl i fixed bin; dcl iocb_ptr ptr; dcl code fixed bin (35); dcl MRDS bit (1) aligned; dcl padding fixed bin; dcl rel_size fixed bin (21); /* Based */ dcl descriptor_bit_36_ovrly bit (36) based; /* Builtin */ dcl (addr, ceil, currentsize, divide, mod, null, rtrim, string) builtin; /* Condition */ dcl cleanup condition; /* Entry */ dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl iox_$delete_record entry (ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl iox_$destroy_iocb entry (ptr, fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)); dcl iox_$seek_key entry (ptr, char (256) var, fixed bin (21), fixed bin (35)); dcl iox_$write_record entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl unique_chars_ entry (bit (*)) returns (char (15)); dcl vrm_open entry (char (*), char (*), bit (36) aligned, fixed bin (35)); dcl vrmu_data_length$get_data_bit_length entry (bit (36)) returns (fixed bin (35)); dcl vrmu_data_align$align_data_item entry (ptr, fixed bin (35)) returns (fixed bin); /* External static */ dcl error_table_$unimplemented_version fixed bin (35) ext static; dcl error_table_$no_record fixed bin (35) ext static; /* Internal static */ dcl ( KSQU init (10), VARYING_BIT_TYPE init (20), VARYING_CHAR_TYPE init (22), WORD init (36) ) fixed bin int static options (constant); /* Structure */ dcl 1 rs_info aligned, 2 version fixed bin init (2), 2 flags aligned, 3 lock_sw bit (1) unal init ("0"b), 3 unlock_sw bit (1) unal init ("0"b), 3 create_sw bit (1) unal init ("1"b), 3 locate_sw bit (1) unal init ("1"b), 3 inc_ref_count bit (1) unal init ("0"b), 3 dec_ref_count bit (1) unal init ("0"b), 3 locate_pos_sw bit (1) unal init ("0"b), 3 mbz bit (29) unal init ("0"b), 2 record_length fixed bin (21) init (0), 2 max_rec_len fixed bin (21) init (0), 2 record_ptr ptr init (null), 2 descriptor fixed bin (35) init (0), 2 ref_count fixed bin (34) init (0), 2 time_last_modified fixed bin (71) init (0), 2 modifier fixed bin (35) init (0), 2 block_ptr ptr unal init (null), 2 mbz2 (2) fixed bin init (0, 0); end vrm_create_relation;  vrm_data_.cds 11/23/84 0800.9rew 11/21/84 0920.2 16020 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ vrm_data_: proc; /* NOTES: This procedure creates the vrm_data_ database. */ /* HISTORY: 82-08-20 R. Harvey: Initially written by stealing from mrds_data_.cds 84-05-18 B. G. Moberg : Changed max_vfile_wait_time to 300 */ %include cds_args; dcl 1 vrmd aligned, /* the values to go into vrm_data_ */ 2 oid_slots_per_section fixed bin (17) init (100), /* Number of opening id slots per section */ 2 max_vfile_wait_time fixed bin (35) init (300), /* max time to wait for file operations for -share option */ 2 max_kattr_length fixed bin (35) init (253), /* maximum length of key */ 2 typed_vector_array_limit fixed bin (35) init (34359738367), /* Max fixed bin 35 */ 2 iocb_list_block_size fixed bin (17) init (100); /* Number of iocbs allowed in each iocb list block */ dcl 1 cdsa like cds_args; dcl code fixed bin (35); dcl (addr, size, string, null) builtin; dcl create_data_segment_ entry (ptr, fixed bin (35)); dcl com_err_ entry options (variable); cdsa.sections.p (1) = addr (vrmd); /* init. info for cds */ cdsa.sections.len (1) = size (vrmd); cdsa.sections.struct_name (1) = "vrmd"; cdsa.seg_name = "vrm_data_"; cdsa.num_exclude_names = 0; cdsa.exclude_array_ptr = null; string (cdsa.switches) = "0"b; cdsa.switches.have_text = "1"b; call create_data_segment_ (addr (cdsa), code); if code ^= 0 then call com_err_ (code, "vrm_data_"); return; end vrm_data_;  vrm_delete_by_id.pl1 04/23/85 1414.2rew 04/23/85 1341.8 114201 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ delete_tuples_by_id: proc (I_cursor_ptr, I_element_id_list_ptr, O_number_deleted, O_code); /* BEGIN_DESCRIPTION Delete the tuples with the tuple ids supplied in the element_id_list. All indexed attribute keys associated with the tuple will also be deleted. The number of tuples deleted will be returned. END_DESCRIPTION */ /* HISTORY 82-10-11 Roger Lackey : Initially written 83-05-24 Roger Lackey: replaced call to record_status to get record_ptr with call to vrmu_cv_vf_desc_to_ptr 84-12-19 Thanh Nguyen : Added code to continue on the next tuple in case of the tuple was just deleted by another parallel process in share mode (by error code = mrds_error_$inconsistent_data_length) and stop the premature tuple_not_found. */ %page; /* delete_tuples_by_id: proc (I_cursor_ptr, I_element_id_list_ptr, O_number_deleted, O_code); */ dcl I_element_id_list_ptr ptr parameter; /* Id_list pointer */ dcl I_cursor_ptr ptr parameter; /* Cursor pointer */ dcl O_number_deleted fixed bin (35) parameter; /* Number of tuples deleted */ dcl O_code fixed bin (35) parameter; /* Error code */ /* Init parameters */ element_id_list_ptr = I_element_id_list_ptr; vrm_cursor_ptr = I_cursor_ptr; O_number_deleted = 0; O_code = 0; if vrm_cursor.switches.meter_sw then do; call cpu_time_and_paging_ (pf_1, t1, pf_dummy); vrm_meter_ptr = vrm_cursor.meter_ptr; vrm_meter.last_call_stats = 0; end; file_locked = "0"b; on cleanup call tidy_up; /* To besure file is unlocked */ call init_delete; /* Setup needed structures */ do x = 1 to element_id_list.number_of_elements; /* Delete a tuple at a time */ tid_ptr = addr (element_id_list.id (x)); /* Get pointer to input tuple_id (tid) */ vfd_ptr = addr (vfile_desc); vfile_desc = 0; vfd.comp_number = tid.comp_num; vfd.comp_offset = tid.offset; call delete_one_tuple (element_id_list.id (x), vfile_desc, vrm_cursor.iocb_ptr); O_number_deleted = O_number_deleted + 1; end; exit: call tidy_up; return; %page; /* * * * * * * * * * * * * * delete_one_tuple * * * * * * * * * * * */ delete_one_tuple: proc (I_tid, I_vf_desc, I_iocb_ptr); dcl I_tid bit (36) aligned parameter; /* Tuple id of tuple to be deleted */ dcl I_vf_desc fixed bin (35); /* Vfile descriptor of tuple to be deleted */ dcl I_iocb_ptr ptr parameter; /* iocb_ptr */ if vrm_cursor.shared then do; if vrm_cursor.opening_mode = KSQU then call lock; /* If sharing the file, lock the vfile while we delete everthing */ end; %page; call vrmu_cv_vf_desc_to_ptr (I_iocb_ptr, I_vf_desc, tuple_ptr, rec_len, code); if code = 0 then do; /* Located the record */ bd_ptr = addr (tuple.data); do i = 1 to ksl_number_of_values; /* Build the primary key from tuple attr values */ vrm_attr_info_ptr = addr (vrm_rel_desc.attr (vrm_open_info.primary_key_info_ptr -> vrm_collection_info.attribute (i).attr_index)); /* to attr info */ key_source_list.val_info.val_ptr (i) = addr (key_vals (i)); /* set source value ptr */ key_source_list.val_info.desc_ptr (i) = addr (vrm_attr_info.descriptor); /* and ptr to descr. */ if vrm_attr_info.varying then do; /* if var. attr. */ offset = tuple.var_offsets (vrm_attr_info.bit_offset); /* bit offset */ key_source_list.val_info.val_ptr (i) = addr (bit_data (offset)); end; /* if varying */ else key_source_list.val_info.val_ptr (i) -> bit_str = substr (data_str, vrm_attr_info.bit_offset, vrm_attr_info.bit_length); end; /* Build primary key list */ call vrmu_encode_key (key_source_list_ptr, pri_key, (0), code); if code ^= 0 then call error (code); /* Now finish up the header on the primary key */ index_ptr = addrel (addr (pri_key), 1); /* past length word of varying string */ index_value_length = 0; /* save warning flag */ index.rel_id = vrm_rel_desc.rel_id; index.index_id = "0"b; if vrm_rel_desc.switches.indexed then do; /* Build list of keys to be delete */ call vrmu_build_index_list (vrm_rel_desc_ptr, vrm_open_info_ptr, tuple_ptr, change_bits_ptr, key_list_ptr, code); if code = 0 then /* Delete the index keys for this record */ call vrmu_delete_indexes (I_iocb_ptr, key_list_ptr, I_tid, code); if code ^= 0 then call error (code); end; call iox_$seek_key (I_iocb_ptr, pri_key, rec_len, code); if code = 0 then call iox_$delete_record (I_iocb_ptr, code); if code ^= 0 then call error (code); end; else if code = mrds_error_$inconsistent_data_length /* Tuple is just deleted by other parallel process in share mode. So it is O.K. to set code to zero. */ then code = 0; if file_locked then call unlock; /* Unlock the file now that we are done */ if code ^= 0 then do; if code = error_table_$no_record then code = dm_error_$no_tuple_id; call error (code); end; if vrm_cursor.switches.meter_sw then vrm_meter.last_call_stats.number_tuples_deleted = vrm_meter.last_call_stats.number_tuples_deleted + 1; end delete_one_tuple; %page; /* * * * * * * * * * * * * * * init_delete * * * * * * * * * * * * * * * */ init_delete: proc; vrm_cursor.switches.shared = vrm_cursor.open_info_ptr -> vrm_open_info.switches.shared; if element_id_list.version ^= ELEMENT_ID_LIST_VERSION_1 then call error (error_table_$unimplemented_version); vrm_open_info_ptr = vrm_cursor.open_info_ptr; vrm_rel_desc_ptr = vrm_cursor.vrm_relation_desc_ptr; vrm_com_ptr = vrm_open_info.com_ptr; if vrm_com.mod_seg_ptr = null () then do; call get_temp_segment_ ("vrm_delete", vrm_com.mod_seg_ptr, code); if code ^= 0 then call error (code); end; /* Instead of allocating the structures are placed in the temp_seg and their pointer calculated by the procedure so freeing does not have to be done */ bit_len = 9 * vrm_rel_desc.maximum_data_length; cb_number_of_change_bits = vrm_rel_desc.number_attrs; ksl_number_of_values = vrm_open_info.primary_key_info_ptr -> vrm_collection_info.number_of_attributes; key_list_ptr = vrm_com.mod_seg_ptr; /* For any indexed attributers */ key_list.number_of_keys = vrm_rel_desc.number_sec_indexes; i = currentsize (key_list); key_source_list_ptr = addrel (key_list_ptr, i + mod (i, 2)); /* For Primary key */ key_source_list.number_of_values = ksl_number_of_values; i = currentsize (key_source_list); kv_ptr = addrel (key_source_list_ptr, i + mod (i, 2)); i = currentsize (key_vals); change_bits_ptr = addrel (kv_ptr, i + mod (i, 2)); change_bits.number_of_change_bits = cb_number_of_change_bits; if cb_number_of_change_bits <= 128 then string (change_bits.position) = substr (all_ones, 1, cb_number_of_change_bits); else string (change_bits.position) = substr (all_ones || all_ones, 1, cb_number_of_change_bits); end init_delete; %page; /* * * * * * * * * * * * * * lock * * * * * * * * * * * * * * * * */ lock: proc; call iox_$control (iocb_ptr, "set_file_lock", addr (LOCK), lock_err_code); if lock_err_code ^= 0 then call error (lock_err_code); file_locked = "1"b; if vrm_cursor.switches.meter_sw then vrm_meter.last_call_stats.number_times_locked = vrm_meter.last_call_stats.number_times_locked + 1; end lock; /* * * * * * * * * * * * * * unlock * * * * * * * * * * * * * * * * */ unlock: proc; if file_locked then do; call iox_$control (iocb_ptr, "set_file_lock", addr (UNLOCK), lock_err_code); if lock_err_code ^= 0 then call error (lock_err_code); end; file_locked = "0"b; end unlock; %page; /* * * * * * * * * * * * * * * * * error * * * * * * * * * * * * * */ error: proc (cd); dcl cd fixed bin (35) parameter; /* Error code */ O_code = cd; goto exit; end error; /* * * * * * * * * * * * * * * * * tidy_up * * * * * * * * * * * * * */ tidy_up: proc; if file_locked then call iox_$control (iocb_ptr, "set_file_lock", addr (UNLOCK), code); if vrm_cursor.switches.meter_sw then do; call cpu_time_and_paging_ (pf_2, t2, pf_dummy); vrm_meter.last_call_stats.last_time_of_stats = clock; t3 = t2 - t1; vrm_meter.last_call_stats.vcpu_time = divide (t3, 1000000, 63); vrm_meter.last_call_stats.page_faults = pf_2 - pf_1; vrm_meter.last_call_stats.number_times_used = 1; vrm_meter.total_stats.last_time_of_stats = 0; vrm_meter.total_stats = vrm_meter.total_stats + vrm_meter.last_call_stats; end; end tidy_up; %page; %include vrm_collection_info; %page; %include vrm_open_info; %page; %include vrm_rel_desc; %page; %include vrm_cursor; %page; %include vrm_com; %page; %include vrm_change_bits; %page; %include vrm_key_list; %page; %include vrm_tuple; %page; %include vrm_index; %page; %include vrm_key_source_list; %page; %include vrm_meter; %page; %include dm_element_id_list; dcl 1 tid aligned based (tid_ptr), /* MRDS tuple id (tid) */ 2 non_std_desc bit (1) unal, /* Non-standard descriptor bit */ 2 temp bit (1) unal, /* On if temp relation */ 2 file_id bit (7) unal, /* File id from mrds db_model file_id_list */ 2 comp_num bit (10) unal, /* Component number */ 2 offset bit (17) unal; /* Offset within component */ dcl tid_ptr pointer; dcl 1 vfd aligned based (vfd_ptr), /* Vfile desc */ 2 pad_1 bit (8) unal, 2 comp_number bit (10) unal, /* Component number */ 2 comp_offset bit (17) unal, /* Offset with in component */ 2 pade_2 bit (1) unal; dcl vfd_ptr pointer; /* Pointer to vfd structure */ %page; dcl addr builtin; dcl addrel builtin; dcl all_ones bit (128) int static options (constant) init ((128)"1"b); dcl bd_ptr ptr; dcl bit_data (bit_len) bit (1) unal based (bd_ptr); dcl bit_len fixed bin (35); dcl bit_str bit (vrm_attr_info.bit_length) based; dcl cleanup condition; dcl clock builtin; dcl code fixed bin (35); dcl cpu_time_and_paging_ entry (fixed bin, fixed bin (71), fixed bin); dcl currentsize builtin; dcl data_str bit (bit_len) based (bd_ptr); dcl divide builtin; dcl dm_error_$no_tuple_id fixed bin (35) ext static; dcl error_table_$no_record fixed bin (35) ext static; dcl error_table_$unimplemented_version fixed bin (35) ext static; dcl file_locked bit (1); dcl fixed builtin; dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl i fixed bin; dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl iox_$delete_record entry (ptr, fixed bin (35)); dcl iox_$seek_key entry (ptr, char (256) var, fixed bin (21), fixed bin (35)); dcl key_vals (ksl_number_of_values) char (vrm_data_$max_kattr_length) based (kv_ptr); /* to hold values so they are aligned */ dcl KSQU fixed bin int static options (constant) init (10); dcl kv_ptr ptr; /* ptr to key values */ dcl lock_err_code fixed bin (35); dcl LOCK bit (2) aligned int static options (constant) init ("10"b); dcl vrm_data_$max_kattr_length ext fixed bin (35); dcl mrds_error_$inconsistent_data_length fixed bin (35) ext static; dcl mod builtin; dcl null builtin; dcl offset fixed bin (35); /* temp attr offset */ dcl pf_1 fixed bin; dcl pf_2 fixed bin; dcl pf_dummy fixed bin; dcl pri_key char (256) var; /* holds encoded primary key */ dcl rel builtin; dcl string builtin; dcl substr builtin; dcl sys_info$max_seg_size fixed bin (35) ext static; dcl t1 fixed bin (71); dcl t2 fixed bin (71); dcl t3 float bin (63); dcl UNLOCK bit (2) aligned int static options (constant) init ("00"b); dcl vrmu_build_index_list entry (ptr, ptr, ptr, ptr, ptr, fixed bin (35)); dcl vrmu_delete_indexes entry (ptr, ptr, bit (36) aligned, fixed bin (35)); dcl vrmu_encode_key entry (ptr, char (256) varying, fixed bin (35), fixed bin (35)); dcl x fixed bin (35); dcl vfile_desc fixed bin (35) aligned; dcl rec_len fixed bin (21); dcl vrmu_cv_vf_desc_to_ptr entry (ptr, fixed bin (35), ptr, fixed bin (21), fixed bin (35)); end delete_tuples_by_id;  vrm_destroy_cursor.pl1 11/23/84 0800.9r w 11/21/84 0933.6 13212 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ vrm_destroy_cursor: destroy_cursor: proc (X_cursor_ptr, I_work_area_ptr, O_code); /* . BEGIN_DESCRIPTION Frees the storage used by a cursor. It will also close and detach the vfile opening associated with the cursor. If metering is being done it will delete the meter for this cursor. . END_DESCRIPTION */ /* History: 82-08-20 R. Harvey: Initially written */ /* Parameters */ dcl I_work_area_ptr ptr; dcl X_cursor_ptr ptr; dcl O_code fixed bin (35); vrm_cursor_ptr = X_cursor_ptr; call vrmu_iocb_manager$destroy_cursor_iocb (vrm_cursor_ptr, code); if code = 0 then do; if vrm_cursor.meter_ptr ^= null then vrm_cursor.meter_ptr -> vrm_meter.cursor_ptr = null; free vrm_cursor in (work_area); end; X_cursor_ptr = null (); O_code = code; %page; dcl code fixed bin (35); dcl vrmu_iocb_manager$destroy_cursor_iocb entry (ptr, fixed bin (35)); dcl work_area area based (I_work_area_ptr); dcl null builtin; %page; %include vrm_cursor; %page; %include vrm_meter; end vrm_destroy_cursor;  vrm_destroy_relation.pl1 11/23/84 0800.9rew 11/21/84 0933.7 31347 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ vrm_destroy_rel_by_opening: destroy_relation_by_opening: proc (I_rel_opening_id, O_code); /* . BEGIN_DESCRIPTION Destroy a given relation. The destroy_by_opening entrypoint will first close the database. . END_DESCRIPTION */ /* History: 82-10-13 R. Harvey: Initially written 83-10-24 Roger Lackey : for better performance changed call to hcs_$status_long to hcs_$get_uid_file to get uid. */ %page; /* destroy_relation_by_opening: proc (I_rel_opening_id, O_code); */ /* Parameters */ dcl I_rel_opening_id bit (36) aligned parameter; dcl O_code fixed bin (35); call vrm_open_man$get_open_info_ptr (I_rel_opening_id, vrm_open_info_ptr, O_code); if O_code ^= 0 then return; dir_path = vrm_open_info.database_dir_path; rel_name = vrm_open_info.relation_name; goto common; vrm_destroy_rel_by_path: destroy_relation_by_path: entry (I_rel_dir, I_rel_name, O_code); /* Parameters */ dcl I_rel_dir char (*) parameter; dcl I_rel_name char (*) parameter; /* dcl O_code fixed bin (35) parameter; */ dir_path = I_rel_dir; rel_name = I_rel_name; /* Look for possible opening id for this relation */ call hcs_$get_uid_file (dir_path, rel_name, file_uid, O_code); /* Try for uid of relation */ if O_code ^= 0 then if O_code ^= error_table_$no_s_permission then return; call vrm_open_man$get_opening_id (file_uid, opening_id, (null ()), vrm_open_info_ptr, O_code); /* Get an opening id */ if O_code ^= 0 then return; common: call vrm_close$release_open_info (vrm_open_info_ptr); /* force a cleanup */ call vrm_open_man$remove_opening (opening_id); call delete_$path (dir_path, rel_name, string (switches), "vfile_relmgr_$destroy_relation", O_code); return; %page; %include vrm_open_info; %page; /* Automatic */ dcl dir_path char (168); dcl rel_name char (32); /* Builtin */ dcl (null, string) builtin; /* Internal static */ dcl 1 switches internal static options (constant), 2 force_sw bit (1) unal init ("0"b), /* Don't delete if protected */ 2 question_sw bit (1) unal init ("1"b), /* Ask the user what to do if protected */ 2 directory_sw bit (1) unal init ("0"b), /* Don't handle directories */ 2 segment_sw bit (1) unal init ("1"b), /* Do handle segments */ 2 link_sw bit (1) unal init ("1"b), /* Do handle links */ 2 chase_sw bit (1) unal init ("1"b); /* Do chase links */ /* External entries */ dcl delete_$path entry (char (*), char (*), bit (6), char (*), fixed bin (35)); dcl vrm_close$release_open_info entry (ptr); dcl vrm_open_man$get_open_info_ptr entry (bit (36) aligned, ptr, fixed bin (35)); dcl vrm_open_man$remove_opening entry (bit (36) aligned); dcl file_uid bit (36) aligned; dcl error_table_$no_s_permission fixed bin (35) ext static; dcl hcs_$get_uid_file entry (char (*), char (*), bit (36) aligned, fixed bin (35)); dcl opening_id bit (36) aligned; dcl vrm_open_man$get_opening_id entry (bit (36) aligned, bit (36) aligned, ptr, ptr, fixed bin (35)); end vrm_destroy_rel_by_opening;  vrm_display_search_list.pl1 11/23/84 0800.9r w 11/21/84 0933.7 68751 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* This program will display a vrm_search_list */ /* History: 05/14/83 Lackey : Originally written 05/19/83 Harvey : Added name output for better debugging 83-08-17 Roger Lackey : Modified to use vrm_cursor_ptr as input parameter */ vrm_display_search_list: vdsl: proc; call cu_$arg_count (nargs, code); if code ^= 0 then call error (code, "Getting nargs"); if nargs ^= 1 then call error (error_table_$wrong_no_of_args, "Usage: vrm_display_search_list virtual_vrm_cursor_ptr"); call cu_$arg_ptr (1, arg_ptr, arg_len, code); if code ^= 0 then call error (code, "Getting arg_ptr"); vrm_cursor_ptr = cv_ptr_ (arg, code); if code ^= 0 then call error (code, "Converting pointer value "); vrm_search_list_ptr = vrm_cursor.search_list_ptr; vrm_rel_desc_ptr = vrm_cursor.vrm_relation_desc_ptr; if vrm_rel_desc_ptr = null () then attr_names_available = "0"b; else attr_names_available = "1"b; goto common; subroutine: entry (I_vrm_cursor_ptr); dcl I_vrm_cursor_ptr ptr parameter; vrm_cursor_ptr = I_vrm_cursor_ptr; vrm_search_list_ptr = vrm_cursor.search_list_ptr; vrm_rel_desc_ptr = vrm_cursor.vrm_relation_desc_ptr; if vrm_rel_desc_ptr = null () then attr_names_available = "0"b; else attr_names_available = "1"b; goto common; %page; common: vrm_open_info_ptr = vrm_cursor.open_info_ptr; call ioa_ ("^2d^5tnum_and_groups", vrm_search_list.num_and_groups); call ioa_ ("^2d^5tmax_num_constraints^/", vrm_search_list.max_num_constraints); do ag = 1 to vrm_search_list.num_and_groups; if vrm_search_list.and_groups (ag).do_not_use_sw then call ioa_ ("^5tDo not use this and group."); if vrm_search_list.and_groups (ag).must_initialize_sw then call ioa_ ("^5tMust initialize this and group."); if vrm_search_list.and_groups (ag).full_key_equal_only_sw then call ioa_ ("^5tFull_key_equal_only."); if vrm_search_list.and_groups (ag).multi_attr_seek_head_sw then call ioa_ ("^5tMulti_attr_seek_head."); if vrm_search_list.and_groups (ag).collection_id_supplied_sw then do; found = "0"b; if vrm_search_list.and_groups (ag).collection_id = THIRTY_SIX_BITS_ALL_OF_THEM_ONES then collection_name = "RECORD COLLECTION"; else if vrm_search_list.and_groups (ag).collection_id = "0"b then collection_name = "PRIMARY KEY"; else do i = 1 to vrm_open_info.number_of_index_collections while (^found); if vrm_search_list.and_groups (ag).collection_id = vrm_open_info.index_collection (i).id then do; found = "1"b; vrm_collection_info_ptr = vrm_open_info.index_collection (i).info_ptr; collection_name = vrm_rel_desc.attr (vrm_collection_info.attribute (1).attr_index).name; end; end; call ioa_ ("^5tCollection id supplied: ^a^/", collection_name); end; call ioa_ ("^2d^5tnum_cons_in_this_and_group", vrm_search_list.and_groups (ag).num_cons_in_this_and_group); call ioa_ ("^2d^5tnum_key_cons_in_this_and_group", vrm_search_list.and_groups (ag).num_key_cons_in_this_and_group); if vrm_search_list.and_groups (ag).num_seek_key_attr_count > 0 then do; call ioa_ ("^2d^5tnum_seek_key_attr_count", vrm_search_list.and_groups (ag).num_seek_key_attr_count); end; call ioa_ (""); do c = 1 to vrm_search_list.and_groups (ag).num_cons_in_this_and_group; if vrm_search_list.and_groups (ag).cons (c).key_attr_sw then do; call convert_to_char (vrm_search_list.and_groups (ag).cons (c).attr_desc_ptr, vrm_search_list.and_groups (ag).cons (c).val_ptr); if vrm_search_list.and_groups (ag).cons (c).seek_head_sw then seek_head = "SEEK_HEAD"; else seek_head = ""; if vrm_search_list.and_groups (ag).cons (c).and_group_search_terminator then and_group_terminator = "AND GROUP SEARCH TERMINATOR"; else and_group_terminator = ""; call ioa_ ("^a^34t^a ^a ^a", vrm_rel_desc.attr (vrm_search_list.and_groups (ag).cons (c).attr_index).name, OP (vrm_search_list.and_groups (ag).cons (c).operator), seek_head, and_group_terminator); call ioa_ ("KEY VALUE^25t^a^/", char_string); end; else if vrm_search_list.and_groups (ag).cons (c).valid_sw then do; call convert_to_char (vrm_search_list.and_groups (ag).cons (c).attr_desc_ptr, vrm_search_list.and_groups (ag).cons (c).val_ptr); call ioa_ ("^a^34t^a", vrm_rel_desc.attr (vrm_search_list.and_groups (ag).cons (c).attr_index).name, OP (vrm_search_list.and_groups (ag).cons (c).operator)); call ioa_ ("NON-KEY VALUE^25t^a^/", char_string); end; end; end; /* END ag = 1 to * */ exit: return; %page; error: proc (cd, msg); dcl cd fixed bin (35) parameter; dcl com_err_ entry () options (variable); dcl msg char (*) parameter; call com_err_ (cd, "vrm_display_search_list", msg); goto exit; end error; %page; convert_to_char: proc (I_desc_ptr, I_data_ptr); dcl I_data_ptr ptr unal parameter; dcl I_desc_ptr ptr unal parameter; desc_ptr = I_desc_ptr; data_ptr = I_data_ptr; num_dims = fixed (desc_ptr -> descriptor.number_dims, 3); t_ptr = addr (char_string); t_type = 44; /* Character varying */ t_len = 1024; s_ptr = data_ptr; s_type = 2 * desc_ptr -> descriptor.type + fixed (desc_ptr -> descriptor.packed, 1); len.scale = fixed (desc_ptr -> descriptor.size.scale, 17); len.precision = fixed (desc_ptr -> descriptor.size.precision, 17); call assign_ (t_ptr, t_type, t_len, s_ptr, s_type, s_len); char_string = """" || char_string; char_string = char_string || """"; return; dcl (t_ptr, s_ptr, data_ptr) ptr; dcl (t_type, s_type) fixed bin; dcl t_len fixed bin (35); dcl 1 len aligned, 2 scale fixed bin (17) unal, 2 precision fixed bin (17) unal; dcl s_len fixed bin (35) based (addr (len)); dcl assign_ entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin, fixed bin (35)); dcl (addr, fixed) builtin; %page; %include mdbm_descriptor; end convert_to_char; %page; %include vrm_search_list; %page; %include vrm_rel_desc; %page; %include vrm_cursor; %page; %include vrm_open_info; %page; %include vrm_collection_info; %page; dcl THIRTY_SIX_BITS_ALL_OF_THEM_ONES bit (36) int static options (constant) init ((36)"1"b); dcl OP (7) char (2) int static options (constant) init ( " =", " >", ">=", " ^", "^=", "<=", " <"); %page; dcl ag fixed bin; dcl arg char (arg_len) based (arg_ptr); dcl arg_len fixed bin (21); dcl arg_ptr ptr; dcl attr_names_available bit (1) aligned; dcl c fixed bin; dcl code fixed bin (35); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl cv_ptr_ entry (char (*), fixed bin (35)) returns (ptr); dcl error_table_$wrong_no_of_args fixed bin (35) ext static; dcl ioa_ entry () options (variable); dcl nargs fixed bin; dcl char_string char (1024) varying; dcl and_group_terminator char (32); dcl seek_head char (20); dcl null builtin; dcl collection_name char (32); dcl found bit (1); dcl i fixed bin; end vrm_display_search_list;  vrm_get_by_id.pl1 04/23/85 1414.2rew 04/23/85 1341.9 91278 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ get_tuple_by_id: proc (I_relation_cursor_ptr, I_element_id, I_id_list_ptr, I_return_area_ptr, O_simple_typed_vector_ptr, O_code); /* . BEGIN_DESCRIPTION Get the value of the specified tuple. The input specification must be converted to a value for vfile_. The record then retrieved from the vfile must then be converted to a vector. . END_DESCRIPTION */ /* History: 82-08-23 R. Harvey: Initially written. 83-05-24 Roger Lackey: replaced call to record_status to get record_ptr with call to vrmu_cv_vf_desc_to_ptr 84-11-27 John Hergert: commented out code that locks file. There doesn't appear to be a reason for locking the file for a retrieve and it was causing numerous file_busy errors. */ %page; /* Parameters */ dcl I_relation_cursor_ptr ptr; /* Cursor of relation */ dcl I_element_id bit (36) aligned; /* Tuple identifier of tuple to be retrieved */ dcl I_id_list_ptr ptr; /* List of attribute numbers to be returned */ dcl I_return_area_ptr ptr; /* User area for tuple and vector allocation */ dcl O_simple_typed_vector_ptr ptr; /* The returned tuple as a vector */ dcl O_code fixed bin (35); O_code = 0; file_locked = "0"b; vrm_cursor_ptr = I_relation_cursor_ptr; on cleanup call tidy_up; call init_get; call process_one_tuple_id (I_element_id, I_id_list_ptr, O_simple_typed_vector_ptr, code); if code ^= 0 then call error (code); O_code = 0; if metering_sw then do; call cpu_time_and_paging_ (pf_2, t2, pf_dummy); vrm_meter.last_call_stats.last_time_of_stats = clock; t3 = t2 - t1; vrm_meter.last_call_stats.vcpu_time = divide (t3, 1000000, 63); vrm_meter.last_call_stats.page_faults = pf_2 - pf_1; vrm_meter.last_call_stats.number_times_used = 1; vrm_meter.total_stats.last_time_of_stats = 0; vrm_meter.total_stats = vrm_meter.total_stats + vrm_meter.last_call_stats; end; Exit: return; %page; get_tuples_by_id: entry (I_relation_cursor_ptr, I_element_id_list_ptr, I_id_list_ptr, I_return_area_ptr, O_simple_typed_vector_list_ptr, O_code); /* Parameters */ dcl I_element_id_list_ptr ptr; /* Tuple identifiers of tuples to be retrieved */ /* dcl I_return_area_ptr ptr; */ /* User area for tuple and vector allocation */ /* dcl I_id_list_ptr ptr; */ /* List of attribute numbers to be returned */ /* dcl I_relation_cursor_ptr ptr; */ /* Cursor of relation */ dcl O_simple_typed_vector_list_ptr ptr; /* The returned tuple as a vector */ /* dcl O_code fixed bin (35); */ O_simple_typed_vector_list_ptr = null; O_code = 0; file_locked = "0"b; on cleanup call tidy_up; on area call error (error_table_$noalloc); element_id_list_ptr = I_element_id_list_ptr; vrm_cursor_ptr = I_relation_cursor_ptr; call init_get; tvl_maximum_number_of_vectors = element_id_list.number_of_elements; allocate typed_vector_list in (return_area) set (typed_vector_list_ptr); O_simple_typed_vector_list_ptr = typed_vector_list_ptr; typed_vector_list.version = TYPED_VECTOR_LIST_VERSION_1; typed_vector_list.number_of_vectors = 0; do i = 1 to element_id_list.number_of_elements; typed_vector_list.vector_ptr (i) = null (); /* So it gets allocated properly... */ call process_one_tuple_id (element_id_list.id (i), I_id_list_ptr, typed_vector_list.vector_ptr (i), code); if code ^= 0 then call error (code); typed_vector_list.number_of_vectors = i; /* Count stored pointers */ end; O_code = 0; call tidy_up; return; %page; init_get: proc; if vrm_cursor.switches.meter_sw then do; call cpu_time_and_paging_ (pf_1, t1, pf_dummy); vrm_meter_ptr = vrm_cursor.meter_ptr; vrm_meter.last_call_stats = 0; metering_sw = "1"b; end; else metering_sw = "0"b; vrm_open_info_ptr = vrm_cursor.open_info_ptr; vrm_com_ptr = vrm_open_info.com_ptr; if vrm_com.get_seg_ptr = null () then do; /* Segment for vfile_ to store retrieved record */ call get_temp_segment_ ("vrm_get_", vrm_com.get_seg_ptr, code); if code ^= 0 then call error (code); get_work_area = empty (); end; vrm_cursor.switches.shared = vrm_open_info.switches.shared; iocb_ptr = vrm_cursor.iocb_ptr; end; %page; process_one_tuple_id: proc (tuple_id, id_list_ptr, simple_typed_vector_ptr, pcode); dcl tuple_id bit (36) aligned parameter; dcl simple_typed_vector_ptr ptr parameter; dcl id_list_ptr ptr parameter; dcl pcode fixed bin (35) parameter; vf_desc = 0; tid_ptr = addr (tuple_id); vfd_ptr = addr (vf_desc); vfd.comp_number = tid.comp_num; vfd.comp_offset = tid.offset; /* No need to lock file when retrieving. This action causes many file busy errors returned to the user on a heavily used db. if vrm_cursor.switches.shared then do; if vrm_cursor.opening_mode = KSQU then call lock; end; */ call vrmu_cv_vf_desc_to_ptr (iocb_ptr, vf_desc, rec_ptr, rec_len, pcode); if pcode = 0 then do; vrm_rel_desc_ptr = vrm_cursor.vrm_relation_desc_ptr; call vrmu_cv_tuple_to_vector$simple_vector (rec_ptr, I_return_area_ptr, id_list_ptr, vrm_rel_desc_ptr, simple_typed_vector_ptr, pcode); if metering_sw then vrm_meter.last_call_stats.number_items_returned = vrm_meter.last_call_stats.number_items_returned + 1; end; /* If we dont lock earlier, no need to unlock now. if file_locked then call unlock; */ return; end process_one_tuple_id; %page; error: proc (ecode); dcl ecode fixed bin (35); if ecode = error_table_$no_record then O_code = dm_error_$no_tuple_id; else O_code = ecode; call tidy_up; go to Exit; end; tidy_up: proc; /* File was never locked. if file_locked then call iox_$control (iocb_ptr, "set_file_lock", addr (UNLOCK), code); */ if metering_sw then do; call cpu_time_and_paging_ (pf_2, t2, pf_dummy); vrm_meter.last_call_stats.last_time_of_stats = clock; t3 = t2 - t1; vrm_meter.last_call_stats.vcpu_time = divide (t3, 1000000, 63); vrm_meter.last_call_stats.page_faults = pf_2 - pf_1; vrm_meter.last_call_stats.number_times_used = 1; vrm_meter.total_stats.last_time_of_stats = 0; vrm_meter.total_stats = vrm_meter.total_stats + vrm_meter.last_call_stats; end; end tidy_up; %page; /* * * * * * * * * * * * * * lock * * * * * * * * * * * * * * * * */ /* since we arent locking... no need for a lock routine. lock: proc; call iox_$control (iocb_ptr, "set_file_lock", addr (LOCK), lock_err_code); if lock_err_code ^= 0 then call error (lock_err_code); file_locked = "1"b; if metering_sw then vrm_meter.last_call_stats.number_times_locked = vrm_meter.last_call_stats.number_times_locked + 1; end lock; */ /* * * * * * * * * * * * * * unlock * * * * * * * * * * * * * * * * */ /* Since we arent locking... no need for an unlock routine. unlock: proc; if file_locked then do; call iox_$control (iocb_ptr, "set_file_lock", addr (UNLOCK), lock_err_code); if lock_err_code ^= 0 then call error (lock_err_code); end; file_locked = "0"b; end unlock; */ %page; /* External entries */ dcl vrmu_cv_tuple_to_vector$simple_vector entry (ptr, ptr, ptr, ptr, ptr, fixed bin (35)); dcl clock builtin; dcl cpu_time_and_paging_ entry (fixed bin, fixed bin (71), fixed bin); dcl divide builtin; dcl pf_1 fixed bin; dcl pf_2 fixed bin; dcl pf_dummy fixed bin; dcl t1 fixed bin (71); dcl t2 fixed bin (71); dcl t3 float bin (63); dcl UNLOCK bit (2) aligned int static options (constant) init ("00"b); dcl LOCK bit (2) aligned int static options (constant) init ("10"b); dcl cleanup condition; dcl file_locked bit (1); dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35)); /* External static */ dcl dm_error_$no_tuple_id fixed bin (35) ext static; dcl error_table_$noalloc fixed bin (35) ext static; dcl error_table_$no_record fixed bin (35) ext static; dcl sys_info$max_seg_size fixed bin (35) ext static; /* Automatic */ dcl code fixed bin (35); dcl i fixed bin (35); dcl iocb_ptr ptr; dcl KSQU fixed bin int static options (constant) init (10); dcl lock_err_code fixed bin (35); dcl rec_len fixed bin (21); dcl rec_ptr ptr; dcl vf_desc fixed bin (35) aligned; dcl vrmu_cv_vf_desc_to_ptr entry (ptr, fixed bin (35), ptr, fixed bin (21), fixed bin (35)); /* Based */ dcl 1 tid aligned based (tid_ptr), /* MRDS tuple id (tid) */ 2 non_std_desc bit (1) unal, /* Non-standard descriptor bit */ 2 temp bit (1) unal, /* On if temp relation */ 2 file_id bit (7) unal, /* File id from mrds db_model file_id_list */ 2 comp_num bit (10) unal, /* Component number */ 2 offset bit (17) unal; /* Offset within component */ dcl tid_ptr pointer; dcl 1 vfd aligned based (vfd_ptr), /* Vfile desc */ 2 pad_1 bit (8) unal, 2 comp_number bit (10) unal, /* Component number */ 2 comp_offset bit (17) unal, /* Offset with in component */ 2 pade_2 bit (1) unal; dcl vfd_ptr pointer; /* Pointer to vfd structure */ dcl metering_sw bit (1) aligned; dcl return_area area based (I_return_area_ptr); dcl get_work_area area (sys_info$max_seg_size) based (vrm_com.get_seg_ptr); /* Builtin */ dcl (addr, empty, fixed, null, rel) builtin; /* Conditions */ dcl area condition; %page; %include vrm_cursor; %page; %include vrm_open_info; %page; %include vrm_rel_desc; %page; %include vrm_com; %page; %include dm_element_id_list; %page; %include dm_typed_vector_list; %page; %include vrm_meter; end get_tuple_by_id;  vrm_get_by_spec.pl1 03/06/85 0822.1r w 03/05/85 0836.6 194076 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ vrm_get_by_spec: proc; /* . BEGIN_DESCRIPTION This program has four entry points: get_tuples_by_spec get_tuple_id get_tuples_and_ids get_count The get_tuples_by_spec entry: Get the attribute values of the tuples identified by a search of a particular index (cursor). The values are vectors allocated in the area supplied by the caller and and are pointed to by a the pointers O_gt_vec_list_ptr -> pointer_array. The get_tuple_id entry: Returns a list of tuple_ids that satisfy the search specification. The get_tuples_and_ids entry: Combines the functions of the get_tuples_by_spec and get_tuple_id entries. The get_count entry: Returns the count of the tuples that satisify the relation_search_specification. The search specification must be limited to attributes supported by the cursor supplied. . END_DESCRIPTION HISTORY 82-08-20 Roger Lackey : Written by 82-11-16 Roger Lackey : Added call to vrm_cursor_man$validate 83-01-11 Roger Lackey : Change get_count entry to retrun n-1 for vfile_status count on MRDS_compatible relations. 83-03-10 Ron Harvey : added the get_tuples_and_ids entry points and allowed the caller to pass in a typed_vector_list to be filled. 83-05-25 Roger Lackey : Changed get_tid and get_tuples_and_ids to allow call to pass in a non_null pointer to element_id_list to be fill. 83-05-25 Roger Lackey : Changed calling sequence to comply with the relation cursor specification. 83-09-08 Roger Lackey : Modified to used new vrm_search_info */ %page; get_tuples_by_spec: entry (I_gt_cursor_ptr, I_gt_spec_ptr, I_gt_id_list_ptr, I_gt_area_ptr, O_gt_vec_list_ptr, O_gt_code); /* PARAMETERS */ dcl I_gt_spec_ptr pointer parameter; /* Pointer to search specification */ dcl I_gt_area_ptr pointer parameter; /* Pointer to base an area upon */ dcl I_gt_id_list_ptr pointer parameter; /* Pointer to attr id_list */ dcl I_gt_cursor_ptr pointer parameter; /* Cursor pointer */ dcl O_gt_vec_list_ptr pointer parameter; /* Pointer to output vector_list */ dcl O_gt_code fixed bin (35) parameter; /* Error code */ entry_type = GET_TUPLE; id_list_ptr = I_gt_id_list_ptr; vrm_cursor_ptr = I_gt_cursor_ptr; relation_search_specification_ptr = I_gt_spec_ptr; area_ptr = I_gt_area_ptr; O_gt_vec_list_ptr = null; O_gt_code = 0; goto common; get_tuples_and_ids: entry (I_gti_cursor_ptr, I_gti_spec_ptr, I_gti_id_list_ptr, I_gti_area_ptr, X_gti_tid_list_ptr, X_gti_vec_list_ptr, O_gti_code); dcl I_gti_spec_ptr ptr parameter; /* Specification structure ptr */ dcl I_gti_area_ptr ptr parameter; /* Return area ptr */ dcl I_gti_id_list_ptr ptr parameter; /* Attribute id list structure */ dcl I_gti_cursor_ptr ptr parameter; /* Cursor pointer */ dcl X_gti_tid_list_ptr ptr parameter; /* Tuple id list structure pointer If null we will allocate the list */ dcl X_gti_vec_list_ptr ptr parameter; /* Typed vector list structure ptr */ dcl O_gti_code fixed bin (35) parameter; /* Error ocde */ entry_type = GET_TUPLE_AND_TID; relation_search_specification_ptr = I_gti_spec_ptr; vrm_cursor_ptr = I_gti_cursor_ptr; area_ptr = I_gti_area_ptr; id_list_ptr = I_gti_id_list_ptr; element_id_list_ptr = X_gti_vec_list_ptr; O_gti_code = 0; goto common; %page; get_tuple_id: entry (I_id_cursor_ptr, I_id_spec_ptr, I_id_area_ptr, X_id_tid_list_ptr, O_id_code); dcl I_id_spec_ptr ptr parameter; /* Specification structure pointer */ dcl I_id_area_ptr ptr parameter; /* Work area pointer */ dcl I_id_cursor_ptr ptr parameter; /* Cursor pointer */ dcl X_id_tid_list_ptr ptr parameter; /* Tuple id list ptr . If null we will allocate the list */ dcl O_id_code fixed bin (35) parameter; /* Error code */ entry_type = GET_TID; relation_search_specification_ptr = I_id_spec_ptr; vrm_cursor_ptr = I_id_cursor_ptr; area_ptr = I_id_area_ptr; element_id_list_ptr = X_id_tid_list_ptr; O_id_code = 0; goto common; get_count: entry (I_count_cursor_ptr, I_count_spec_ptr, O_count_number, O_count_code); dcl I_count_spec_ptr ptr parameter; /* Specification_structure pointer */ dcl I_count_cursor_ptr ptr parameter; /* Cursor pointer */ dcl O_count_number fixed bin (35) parameter; /* Number of tuples counted that met search spec */ dcl O_count_code fixed bin (35) parameter; /* Error code */ relation_search_specification_ptr = I_count_spec_ptr; vrm_cursor_ptr = I_count_cursor_ptr; O_count_number = 0; O_count_code = 0; entry_type = GET_COUNT; goto common; %page; common: if vrm_cursor.switches.meter_sw /* If metering is being done */ then do; call cpu_time_and_paging_ (pf_1, t1, dummy); vrm_meter_ptr = vrm_cursor.meter_ptr; vrm_meter.last_call_stats = 0; metering_sw = "1"b; end; else metering_sw = "0"b; file_locked = "0"b; vrm_cursor.switches.shared = vrm_cursor.open_info_ptr -> vrm_open_info.switches.shared; if area_seg_ptr = null then do; vrm_com_ptr = vrm_cursor.open_info_ptr -> vrm_open_info.com_ptr; if vrm_com.get_seg_ptr = null then do; call get_temp_segment_ (MY_NAME, vrm_com.get_seg_ptr, code); if code ^= 0 then call error (code); end; area_seg_ptr = vrm_com.get_seg_ptr; get_area = empty (); end; vrm_search_info_ptr = addr (search_info); search_info.cur_id_list_ix = 0; if entry_type = GET_TUPLE | entry_type = GET_TUPLE_AND_TID then vrm_search_info.tuple_pointer_required = "1"b; else vrm_search_info.tuple_pointer_required = "0"b; if entry_type = GET_TID | entry_type = GET_TUPLE_AND_TID then vrm_search_info.tuple_tid_required = "1"b; else vrm_search_info.tuple_tid_required = "0"b; if metering_sw then vrm_search_info.meter_sw = "1"b; else vrm_search_info.meter_sw = "0"b; vrm_search_info.upper_limit_exceeded_sw = "0"b; vrm_search_info.last_call_stats = 0; vrm_rel_desc_ptr = vrm_cursor.vrm_relation_desc_ptr; iocb_ptr = vrm_cursor.iocb_ptr; items_found = 0; all_range_spec = "0"b; on cleanup call tidy_up; %page; if relation_search_specification_ptr = null /* No search specification supplied */ then do; rss_maximum_number_of_constraints = 0; /* Just to keep the compiler happy */ all_range_spec = "1"b; /* Get everything */ search_info.max_number_values = vrm_data_$typed_vector_array_limit; end; else do; /* There was a search specification supplied */ if relation_search_specification.head.type ^= ABSOLUTE_RELATION_SEARCH_SPECIFICATION_TYPE & relation_search_specification.head.type ^= RELATIVE_RELATION_SEARCH_SPECIFICATION_TYPE then call error (dm_error_$unsup_search_spec_head_type); if relation_search_specification.head.type = ABSOLUTE_RELATION_SEARCH_SPECIFICATION_TYPE then do; all_range_spec = "1"b; search_info.max_number_values = vrm_data_$typed_vector_array_limit; end; if relation_search_specification.range.type = LOW_RANGE_TYPE then search_info.max_number_values = relation_search_specification.range.size; end; if all_range_spec then do; /* Build an internal version of the search spec */ call vrmu_search_init (vrm_cursor_ptr, relation_search_specification_ptr, code); if code ^= 0 then call error (code); end; if vrm_cursor.search_list_ptr = null then do; call sub_err_ (mrds_error_$internal_error, MY_NAME, ACTION_CANT_RESTART, null, 0, "A dm_search_specification with a RELATIVER_RELATION_SEARCH_SPECIFICATION_TYPE before a ABSOLUTE_RELATION_SEARCH_SPECIFICATION_TYPE."); end; vrm_search_list_ptr = vrm_cursor.search_list_ptr; if vrm_search_list.num_and_groups > 0 then do; cur_ag = 0; do ag = 1 to vrm_search_list.num_and_groups while (cur_ag = 0); if vrm_search_list.and_groups (ag).do_not_use_sw = "0"b then cur_ag = ag; end; if cur_ag = 0 then call error (dm_error_$no_tuple); else vrm_search_list.current_and_group = cur_ag; end; %page; if (entry_type = GET_TID | entry_type = GET_TUPLE_AND_TID) then do; /* Set ptr for tid list */ if element_id_list_ptr = null then do; /* Element id list was NOT passed in */ element_id_list_supplied_sw = "0"b; /* Was not supplied */ if tid_temp_seg_ptr = null then do; call get_temp_segment_ (MY_NAME, tid_temp_seg_ptr, code); if code ^= 0 then call error (code); end; element_id_list_ptr = tid_temp_seg_ptr; element_id_list.version = ELEMENT_ID_LIST_VERSION_1; element_id_list.number_of_elements = search_info.max_number_values; end; else do; /* Element_id_list supplied */ element_id_list_supplied_sw = "1"b; if element_id_list.version ^= ELEMENT_ID_LIST_VERSION_1 then call error (error_table_$unimplemented_version); element_id_list.number_of_elements = search_info.max_number_values; /* this is the way it has to be */ end; search_info.tid_list_ptr = element_id_list_ptr; end; if (entry_type = GET_TUPLE | entry_type = GET_TUPLE_AND_TID) then do; /* Set ptr for tuple list */ typed_vector_list_ptr = null (); if entry_type = GET_TUPLE_AND_TID then if X_gti_vec_list_ptr ^= null then typed_vector_list_ptr = X_gti_vec_list_ptr; if entry_type = GET_TUPLE then if O_gt_vec_list_ptr ^= null then typed_vector_list_ptr = O_gt_vec_list_ptr; if typed_vector_list_ptr = null then do; /* none passed in */ if tuple_temp_seg_ptr = null then do; /* first non-null call */ call get_temp_segment_ (MY_NAME, tuple_temp_seg_ptr, code); if code ^= 0 then call error (code); end; typed_vector_list_ptr = tuple_temp_seg_ptr; typed_vector_list.version = TYPED_VECTOR_LIST_VERSION_1; end; else /* typed_vector_list was passed in */ search_info.max_number_values = min (typed_vector_list.maximum_number_of_vectors, search_info.max_number_values); if typed_vector_list.version ^= TYPED_VECTOR_LIST_VERSION_1 then call error (error_table_$unimplemented_version); if typed_vector_list_ptr = tuple_temp_seg_ptr then typed_vector_list.maximum_number_of_vectors = search_info.max_number_values; end; %page; if entry_type = GET_COUNT & relation_search_specification_ptr = null then do; /* No search constraints so use vfile_status */ O_count_number = 0; vfsi.info_version = 1; call iox_$control (iocb_ptr, "file_status", addr (vfsi), code); if code = 0 then do; /* Give um the count */ if vrm_rel_desc.switches.MRDS_compatible then O_count_number = vfsi.non_null_recs - 1; /* Cause they have one null record */ else O_count_number = vfsi.non_null_recs; /* Actual count */ end; O_count_code = code; goto exit; end; if db_sw then call vrm_display_search_list$subroutine (vrm_cursor_ptr); %page; /* Following loop does the work */ if vrm_cursor.switches.shared then do; if vrm_cursor.opening_mode = KSQU then call lock; /* If in shared mode we must lock the file */ end; code = 0; do while (code = 0 & items_found < search_info.max_number_values); search_info.num_items_returned = 0; call vrmu_search (vrm_search_info_ptr, vrm_cursor_ptr, code); if search_info.num_items_returned > 0 then call add_to_output_list; /* Got a tuple or tid even if code = dm_error_$no_tuple there still could be items_returned that are valid so add them to the output list before checking error code */ if code ^= 0 then do; if code ^= dm_error_$no_tuple then call error (code); if vrm_search_list.current_and_group + 1 < vrm_search_list.num_and_groups then do; vrm_search_list.current_and_group = vrm_search_list.current_and_group + 1; code = 0; end; end; end; if file_locked then call unlock; %page; if items_found ^= 0 then do; /* Found some tuples or tids */ if tuple_temp_seg_ptr = typed_vector_list_ptr & (entry_type = GET_TUPLE | entry_type = GET_TUPLE_AND_TID) then do; /* Build the returned vector_pointer array */ on area call error (error_table_$noalloc); tvl_maximum_number_of_vectors = items_found; allocate typed_vector_list in (wa) set (typed_vector_list_ptr); typed_vector_list.version = TYPED_VECTOR_LIST_VERSION_1; typed_vector_list.pad = 0; typed_vector_list.number_of_vectors = items_found; tuple_temp_seg_ptr -> typed_vector_list.maximum_number_of_vectors = items_found; /* Cut temp copy down to size */ typed_vector_list_ptr -> typed_vector_list.vector_ptr = /* Copy temp list into callers area */ tuple_temp_seg_ptr -> typed_vector_list.vector_ptr; if entry_type = GET_TUPLE then O_gt_vec_list_ptr = typed_vector_list_ptr; else X_gti_vec_list_ptr = typed_vector_list_ptr; end; if entry_type = GET_TID | entry_type = GET_TUPLE_AND_TID then do; eil_number_of_elements = items_found; if ^element_id_list_supplied_sw then do; allocate element_id_list in (wa) set (element_id_list_ptr); element_id_list.number_of_elements = items_found; tid_temp_seg_ptr -> element_id_list.number_of_elements = items_found; element_id_list = tid_temp_seg_ptr -> element_id_list; if entry_type = GET_TID then X_id_tid_list_ptr = element_id_list_ptr; else X_gti_tid_list_ptr = element_id_list_ptr; end; /* END if ^element_id_list_supplied_sw then do; */ else element_id_list.number_of_elements = items_found; /* element id list supplied */ end; if entry_type = GET_COUNT then /* all that's left */ O_count_number = items_found; /* entry_type = GET_COUNT */ end; %page; /* Some kind of an error to return */ else do; if entry_type = GET_TUPLE then O_gt_code = dm_error_$no_tuple; else if entry_type = GET_TID then O_id_code = dm_error_$no_tuple; else if entry_type = GET_TUPLE_AND_TID then O_gti_code = dm_error_$no_tuple; else O_count_code = 0; end; if db_sw then call ioa_ ("^/Number items returned: ^d^/", items_found); exit: call tidy_up; return; %page; /* * * * * * * * * * * * * add_to_output_list * * * * * * * * * * * * */ add_to_output_list: proc; if entry_type = GET_TUPLE | entry_type = GET_TUPLE_AND_TID then do; do n = 1 to search_info.num_items_returned; items_found = items_found + 1; if typed_vector_list_ptr = tuple_temp_seg_ptr /* we did the allocation */ then vector_ptr = null (); /* make sure it is not garbage */ else vector_ptr = typed_vector_list.vector_ptr (items_found); /* get user's stv ptr */ tuple_ptr = search_info.tup_ptr (n); call vrmu_cv_tuple_to_vector$simple_vector (tuple_ptr, area_ptr, id_list_ptr, vrm_rel_desc_ptr, vector_ptr, err_code); if err_code ^= 0 then call error (err_code); typed_vector_list.vector_ptr (items_found) = vector_ptr; end; end; else /* entry_type ^= GET_TUPLE | entry_type ^= GET_TUPLE_AND_TID */ items_found = items_found + search_info.num_items_returned; search_info.cur_id_list_ix = items_found; end add_to_output_list; %page; /* * * * * * * * * * * * * * * error * * * * * * * * * * * * * * * */ error: proc (cd); dcl cd fixed bin (35) parameter; if entry_type = GET_TUPLE then O_gt_code = cd; else if entry_type = GET_TID then O_id_code = cd; else if entry_type = GET_TUPLE_AND_TID then O_gti_code = cd; else O_count_code = cd; goto exit; end error; /* * * * * * * * * * * * * tidy_up * * * * * * * * * * * * * * * * * * */ tidy_up: proc; if file_locked then call iox_$control (iocb_ptr, "set_file_lock", addr (UNLOCK), code); if metering_sw then do; call cpu_time_and_paging_ (pf_2, t2, dummy); vrm_meter.last_call_stats = vrm_search_info.last_call_stats; vrm_meter.last_call_stats.last_time_of_stats = clock; t3 = t2 - t1; vrm_meter.last_call_stats.vcpu_time = divide (t3, 1000000, 63); vrm_meter.last_call_stats.page_faults = pf_2 - pf_1; vrm_meter.last_call_stats.number_items_returned = items_found; if vrm_search_info.upper_limit_exceeded_sw then vrm_meter.last_call_stats.upper_limit_found_count = vrm_meter.last_call_stats.upper_limit_found_count + 1; vrm_meter.last_call_stats.number_times_used = 1; vrm_meter.total_stats.last_time_of_stats = 0; vrm_meter.total_stats = vrm_meter.total_stats + vrm_meter.last_call_stats; end; end tidy_up; %page; /* * * * * * * * * * * * * * lock * * * * * * * * * * * * * * * * */ lock: proc; if metering_sw then search_info.last_call_stats.number_times_locked = search_info.last_call_stats.number_times_locked + 1; call iox_$control (iocb_ptr, "set_file_lock", addr (LOCK), lock_err_code); if lock_err_code ^= 0 then call error (lock_err_code); file_locked = "1"b; end lock; /* * * * * * * * * * * * * * unlock * * * * * * * * * * * * * * * * */ unlock: proc; if file_locked then do; call iox_$control (iocb_ptr, "set_file_lock", addr (UNLOCK), lock_err_code); if lock_err_code ^= 0 then call error (lock_err_code); end; file_locked = "0"b; end unlock; /* * * * * * * * * * * * * * * * * * * debug * * * * * * * * * * * */ db_on: entry; db_sw = "1"b; return; db_off: entry; db_sw = "0"b; return; %page; %include dm_specification_head; %page; %include dm_relation_spec; %page; %include dm_range_constants; %page; %include vrm_rel_desc; %page; %include vrm_cursor; %page; %include vrm_search_list; %page; %include vrm_meter; %page; %include dm_element_id_list; %page; %include dm_typed_vector_list; %page; %include vrm_tuple; %page; %include vrm_open_info; %page; %include vrm_search_info; %page; %include vfs_info; %page; %include vrm_com; %page; %include sub_err_flags; dcl 1 search_info like vrm_search_info aligned; dcl 1 vfsi like indx_info; %page; dcl addr builtin; dcl ag fixed bin; dcl all_range_spec bit (1) aligned; dcl area condition; dcl area_ptr ptr; dcl area_seg_ptr ptr int static init (null); dcl cleanup condition; dcl clock builtin; dcl code fixed bin (35); dcl cpu_time_and_paging_ entry (fixed bin, fixed bin (71), fixed bin); dcl cur_ag fixed bin; dcl db_sw bit (1) int static init ("0"b); dcl divide builtin; dcl dm_error_$no_tuple fixed bin (35) ext static; dcl dm_error_$unsup_search_spec_head_type fixed bin (35) ext static; dcl dummy fixed bin; dcl element_id_list_supplied_sw bit (1) aligned; dcl empty builtin; dcl entry_type fixed bin; dcl err_code fixed bin (35); dcl error_table_$noalloc fixed bin (35) ext static; dcl error_table_$unimplemented_version fixed bin (35) ext static; dcl file_locked bit (1); dcl fixed builtin; dcl get_area area (sys_info$max_seg_size) based (area_seg_ptr); dcl GET_COUNT fixed bin int static options (constant) init (3); dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl GET_TID fixed bin int static options (constant) init (2); dcl GET_TUPLE fixed bin int static options (constant) init (1); dcl GET_TUPLE_AND_TID fixed bin int static options (constant) init (4); dcl id_list_ptr ptr; dcl info fixed bin; /* Dummy variable for vfsi like */ dcl ioa_ entry () options (variable); dcl iocb_ptr ptr; dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl items_found fixed bin (35); dcl KSQU fixed bin int static options (constant) init (10); dcl LOCK bit (2) aligned int static options (constant) init ("10"b); dcl lock_err_code fixed bin (35); dcl metering_sw bit (1) aligned; dcl min builtin; dcl mrds_error_$internal_error fixed bin (35) ext static; dcl MY_NAME char (24) int static options (constant) init ("vrm_get_by_spec"); dcl n fixed bin; dcl null builtin; dcl pf_1 fixed bin; dcl pf_2 fixed bin; dcl rel builtin; dcl sub_err_ entry () options (variable); dcl sys_info$max_seg_size fixed bin (35) ext static; dcl t1 fixed bin (71); dcl t2 fixed bin (71); dcl t3 float bin (63); dcl tid_temp_seg_ptr ptr internal static init (null); dcl tuple_temp_seg_ptr ptr internal static init (null); dcl UNLOCK bit (2) aligned int static options (constant) init ("00"b); dcl vector_ptr ptr; dcl vrmu_cv_tuple_to_vector$simple_vector entry (ptr, ptr, ptr, ptr, ptr, fixed bin (35)); dcl vrmu_search entry (ptr, ptr, fixed bin (35)); dcl vrmu_search_init entry (ptr, ptr, fixed bin (35)); dcl vrm_data_$typed_vector_array_limit fixed bin (35) ext static; dcl vrm_display_search_list$subroutine entry (ptr); dcl wa area based (area_ptr); end vrm_get_by_spec;  vrm_get_description.pl1 11/23/84 0800.9r w 11/21/84 0933.8 35928 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ get_description: proc (I_rel_opening_id, I_return_area_ptr, O_relation_description_ptr, O_code); /* . BEGIN_DESCRIPTION Allocate and fill in a relation_description structure for the specified relation. . END_DESCRIPTION */ /* History 83-01-15 R. Harvey: Initially written 83-02-17 R. Harvey: Modified for version 3 relation_description by adding attribute names. */ %page; /* get_description: proc (I_rel_opening_id, I_return_area_ptr, O_relation_description_ptr, O_code); */ /* Parameters */ dcl I_rel_opening_id bit (36) aligned parameter; dcl I_return_area_ptr ptr parameter; dcl O_relation_description_ptr ptr parameter; dcl O_code fixed bin (35) parameter; O_code = 0; O_relation_description_ptr = null (); call vrm_open_man$get_open_info_ptr (I_rel_opening_id, vrm_open_info_ptr, code); if code ^= 0 then call error (code); vrm_rel_desc_ptr = vrm_open_info.relation_model_ptr; rd_number_of_attributes = vrm_rel_desc.number_attrs; rd_number_of_indices = vrm_open_info.number_of_index_collections + 1; /* one for the primary key */ rd_maximum_number_of_attributes_per_index = vrm_rel_desc.number_primary_key_attrs; rd_maximum_attribute_name_length = 32; allocate relation_description in (return_area) set (relation_description_ptr); relation_description.version = RELATION_DESCRIPTION_VERSION_3; relation_description.record_collection_id = "111111111111111111111111111111111111"b; do i = 1 to rd_number_of_attributes; relation_description.attribute (i).name = vrm_rel_desc.attr (i).name; relation_description.attribute (i).descriptor_ptr = addr (vrm_rel_desc.attr (i).descriptor); end; /* Copy primary key information */ vrm_collection_info_ptr = vrm_open_info.primary_key_info_ptr; relation_description.index (1).collection_id = "0"b; relation_description.index (1).style = 0; /* multi-field sorting */ relation_description.index (1).number_of_attributes = vrm_rel_desc.number_primary_key_attrs; relation_description.index (1).flags.is_unique = "1"b; relation_description.index (1).flags.is_primary = "1"b; relation_description.index (1).flags.pad = "0"b; do j = 1 to vrm_collection_info.number_of_attributes; relation_description.index (1).attribute (j) = vrm_collection_info.attribute (j).attr_index; end; do i = 1 to rd_number_of_indices - 1; vrm_collection_info_ptr = vrm_open_info.index_collection (i).info_ptr; relation_description.index (i + 1).collection_id = vrm_open_info.index_collection (i).id; relation_description.index (i + 1).style = 0;/* multi-field sorting */ relation_description.index (i + 1).number_of_attributes = 1; relation_description.index (i + 1).flags.is_unique = "0"b; relation_description.index (i + 1).flags.is_primary = "0"b; relation_description.index (i + 1).flags.pad = "0"b; relation_description.index (i + 1).attribute (1) = vrm_collection_info.attribute (1).attr_index; end; O_relation_description_ptr = relation_description_ptr; O_code = 0; Exit: return; %page; error: proc (ecode); dcl ecode fixed bin (35) parameter; O_code = ecode; goto Exit; end error; %page; %include vrm_open_info; %page; %include vrm_rel_desc; %page; %include vrm_collection_info; %page; %include dm_relation_description; %page; /* Automatic */ dcl code fixed bin (35); dcl (i, j) fixed bin; /* Based */ dcl return_area area based (I_return_area_ptr); /* Builtin */ dcl (addr, null) builtin; /* External entry */ dcl vrm_open_man$get_open_info_ptr entry (bit (36) aligned, ptr, fixed bin (35)); end get_description;  vrm_get_duplicate_key_count.pl1 11/23/84 0800.9rew 11/21/84 0933.8 30240 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ vrm_get_duplicate_key_count: get_duplicate_key_count: proc (I_relation_cursor_ptr, I_index_collection_id, I_num_dup_fields, O_count, O_code); /* BEGIN_DESCRIPTION The purpose of this procedure is to provide an approximate number of duplicate keys. The method used is to use vfile_status_ to get the number of total number duplicate keys and divide that numbe by the number of indexed attributes in the relation pluse one for the primary key. END_DESCRIPTION */ /* HISTORY 82-10-06: Roger Lackey : Initially written 83-10-21: Roger Lackey : added check for vrm_rel_desc.number_sec_indexes = 0 to eliminate posibility of divide by zero. */ /* PARAMETERS */ dcl I_relation_cursor_ptr ptr parameter; /* Cursor pointer */ dcl I_index_collection_id bit (36) aligned parameter; /* collection id to get statistics for (ignored ) */ dcl I_num_dup_fields fixed bin parameter; /* NOT USED BY vrm */ dcl O_count fixed bin (35) parameter; /* Returned dup key count */ dcl O_code fixed bin (35) parameter; /* Error code */ vrm_cursor_ptr = I_relation_cursor_ptr; O_count = 0; O_code = 0; if vrm_cursor.switches.meter_sw then do; call cpu_time_and_paging_ (pf_1, t1, pf_dummy); vrm_meter_ptr = vrm_cursor.meter_ptr; vrm_meter.last_call_stats = 0; end; vrm_cursor.switches.shared = vrm_cursor.open_info_ptr -> vrm_open_info.switches.shared; vrm_rel_desc_ptr = vrm_cursor.vrm_relation_desc_ptr; vfsi.info_version = 1; call iox_$control (vrm_cursor.iocb_ptr, "file_status", addr (vfsi), code); if code = 0 then do; /* Give um the count */ if vfsi.dup_keys = 0 | vrm_rel_desc.number_sec_indexes = 0 then O_count = 0; else O_count = divide (vfsi.dup_keys, (vrm_rel_desc.number_sec_indexes), 24, 0); end; O_code = code; if vrm_cursor.switches.meter_sw then do; call cpu_time_and_paging_ (pf_2, t2, pf_dummy); vrm_meter.last_call_stats.last_time_of_stats = clock; t3 = t2 - t1; vrm_meter.last_call_stats.vcpu_time = divide (t3, 1000000, 63); vrm_meter.last_call_stats.page_faults = pf_2 - pf_1; vrm_meter.last_call_stats.number_times_used = 1; vrm_meter.total_stats.last_time_of_stats = 0; vrm_meter.total_stats = vrm_meter.total_stats + vrm_meter.last_call_stats; end; %page; %include vrm_meter; %page; %include vrm_rel_desc; %page; %include vrm_cursor; %page; %include vrm_open_info; %page; %include vfs_info; %page; dcl 1 vfsi like indx_info; dcl addr builtin; dcl clock builtin; dcl code fixed bin (35); dcl cpu_time_and_paging_ entry (fixed bin, fixed bin (71), fixed bin); dcl divide builtin; dcl info fixed bin; /* Dummy variable for vfsi like */ dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl pf_1 fixed bin; dcl pf_2 fixed bin; dcl pf_dummy fixed bin; dcl t1 fixed bin (71); dcl t2 fixed bin (71); dcl t3 float bin (63); end vrm_get_duplicate_key_count;  vrm_get_population.pl1 11/23/84 0800.9r w 11/21/84 0933.8 19584 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ get_population: proc (I_rel_cursor_ptr, O_number_of_tuples, O_code); /* BEGIN_DESCRIPTION This routine will return the number of tuples in the specified relation by asking vfile_ for its count. This is very fast and very accurate. END_DESCRIPTION */ /* HISTORY 19 September 1983 R. Harvey: Initially written */ %page; /* get_population: proc (I_rel_cursor_ptr, O_number_of_tuples, O_code); */ /* Parameters */ dcl I_rel_cursor_ptr ptr; dcl O_number_of_tuples fixed bin (35); dcl O_code fixed bin (35); O_number_of_tuples = 0; /* init */ O_code = 0; vrm_cursor_ptr = I_rel_cursor_ptr; vrm_open_info_ptr = vrm_cursor.open_info_ptr; iocb_ptr = vrm_cursor.iocb_ptr; vrm_rel_desc_ptr = vrm_open_info.relation_model_ptr; vfsi.info_version = vfs_version_1; call iox_$control (iocb_ptr, "file_status", addr (vfsi), code); if code ^= 0 then call error (code); /* Now we have a count of what vfile_ thinks is there. We need to adjust this to conform to reality */ if vrm_rel_desc.switches.MRDS_compatible then O_number_of_tuples = vfsi.non_null_recs - 1; /* because there is really a null record */ else O_number_of_tuples = vfsi.non_null_recs - 1 - vrm_open_info.number_of_index_collections; Exit: return; error: proc (ecode); dcl ecode fixed bin (35) parameter; O_code = ecode; go to Exit; end error; %page; %include vrm_open_info; %page; %include vrm_rel_desc; %page; %include vrm_cursor; %page; %include vfs_info; %page; /* Automatic */ dcl code fixed bin (35); dcl info fixed bin; /* dummy variable to keep compiler happy */ dcl iocb_ptr ptr; dcl 1 vfsi like indx_info; /* Builtin */ dcl addr builtin; /* External entry */ dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); end get_population;  vrm_index.pl1 11/23/84 0800.9rew 11/21/84 0920.2 192006 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ create_index: proc (I_rel_opening_id, I_id_list_ptr, I_flags, I_style, O_index_collection_id, O_code); /* . BEGIN_DESCRIPTION Create an index for a relation using exactly ONE of the relation's attributes. When called with the Unique index bit set in the flags structure, a primary key will be assumed and the index_collection_id returned will be all zero bits in this case. In the case of a single indexed attribute, the collection id will be the bit string equivalent of the attribute number. The only bit in the flags structure that is honored is the 'relation_must_be_empty' flag. If the relation is found to not be empty when this flag is set, an error code will be returned and the index will not be created. The 'style' parameter is ignored. . END_DESCRIPTION */ /* History: 82-09-29 R. Harvey: Initially written 82-11-02 R. Harvey: Modified for internal relation info structure 82-11-30 R. Harvey: Modified to not use scan_records so that stationary records relations work properly. 83-01-19 R. Harvey: Modified so that destruction of indices is done without looking at each tuple. 83-06-07 Roger Lackey : Added vrm_rel_desc.attr info for relation cursors 83-10-03 Roger Lackey : Changed the way that key offsets wer calculated and added key_bit_len value to collection info. 84-05-25 Bert Moberg : Changed to call the new routine vrmu_encode_key$compute_offset_and_length to properly calculate key offsets and lengths 84-05-30 Bert Moberg : Changed the new call to vrmu_encode_key$compute_offset_and_length to call vrmu_encode_key$compute_alignment_and_length as there was one case were the first try did not work. */ %page; /* create_index: proc (I_rel_opening_id, I_id_list_ptr, I_flags, I_style, O_index_collection_id, O_code); */ /* Parameters */ dcl I_rel_opening_id bit (36) aligned; dcl I_id_list_ptr ptr; dcl I_flags bit (36) aligned; dcl I_style fixed bin (17); dcl O_index_collection_id bit (36) aligned; dcl O_code fixed bin (35); O_index_collection_id = "0"b; O_code = 0; id_list_ptr = I_id_list_ptr; if id_list.version ^= ID_LIST_VERSION_1 then call error (error_table_$unimplemented_version); string (flags) = I_flags; change_bits_ptr, key_list_ptr, scan_iocb_ptr, index_iocb_ptr, pk_iocb_ptr, get_key_info_ptr, rs_info_ptr = null; on cleanup call tidy_up; call vrm_open_man$get_open_info_ptr (I_rel_opening_id, vrm_open_info_ptr, code); if code ^= 0 then call error (code); vrm_rel_desc_ptr = vrm_open_info.relation_model_ptr; vrm_com_ptr = vrm_open_info.com_ptr; if ^flags.index_is_unique then do; /* assume non-primary key */ attr_no = id_list.id (1); /* only support one-attribute indexes for now */ call init_create; vrm_rel_desc.number_sec_indexes = vrm_rel_desc.number_sec_indexes + 1; vci_no_of_attributes = 1; allocate vrm_collection_info in (wa) set (vrm_collection_info_ptr); call calculate_collection_id (attr_no, O_index_collection_id); vrm_collection_info.id = substr (O_index_collection_id, 1, 8); vrm_collection_info.unique = "0"b; vrm_collection_info.primary_key = "0"b; vrm_collection_info.pad = "0"b; call fill_attribute_info; call add_collection_info; do x = 1 to vrm_collection_info.number_of_attributes; ax = vrm_collection_info.attribute (x).attr_index; vrm_rel_desc.attr (ax).primary_key_attr = "0"b; if vrm_collection_info.attribute (x).key_offset = 0 then vrm_rel_desc.attr (ax).key_head = "1"b; end; tuple_ptr = addr (tuple_ptr); /* make sure non-null */ do while (tuple_ptr ^= null ()); call get_a_tuple (scan_iocb_ptr, file_id, tuple_id, tuple_ptr); if tuple_ptr ^= null () then do; call vrmu_build_index_list (vrm_rel_desc_ptr, vrm_open_info_ptr, tuple_ptr, change_bits_ptr, key_list_ptr, code); if code = 0 then call vrmu_add_indexes (index_iocb_ptr, key_list_ptr, tuple_id, code); if code ^= 0 then call error (code); end; /* tuple_ptr ^ null */ end; /* do while */ end; /* index not unique */ else do; /* primary key */ O_index_collection_id = "0"b; vci_no_of_attributes = id_list.number_of_ids; allocate vrm_collection_info in (wa) set (vrm_collection_info_ptr); vrm_collection_info.id = "0"b; vrm_collection_info.unique = "1"b; vrm_collection_info.primary_key = "1"b; vrm_collection_info.pad = "0"b; call fill_attribute_info; call add_collection_info; vrm_rel_desc.number_primary_key_attrs = id_list.number_of_ids; vrm_open_info.primary_key_info_ptr = vrm_collection_info_ptr; do x = 1 to vrm_collection_info.number_of_attributes; ax = vrm_collection_info.attribute (x).attr_index; vrm_rel_desc.attr (ax).primary_key_attr = "1"b; if vrm_collection_info.attribute (x).key_offset = 0 then vrm_rel_desc.attr (ax).key_head = "1"b; end; end; /* primary key */ if ^vrm_rel_desc.MRDS_compatible then do; /* create info record */ call open_iocb (KSQU, "vrm_key_info", pk_iocb_ptr); if code ^= 0 then call error (code); call iox_$seek_key (pk_iocb_ptr, VRM_COLLECTION_KEY_HEAD || char (O_index_collection_id), (0), code); if code ^= error_table_$no_record & code ^= 0 then call error (code); call iox_$write_record (pk_iocb_ptr, vrm_collection_info_ptr, currentsize (vrm_collection_info), code); if code ^= 0 then call error (code); end; /* (non-MRDS) */ call tidy_up; Exit: return; %page; destroy_index: entry (I_rel_opening_id, I_index_collection_id, O_code); /* Parameters */ /* dcl I_rel_opening_id bit (36) aligned parameter; */ dcl I_index_collection_id bit (36) aligned parameter; /* dcl O_code fixed bin (35) parameter; */ O_code = 0; call vrm_open_man$get_open_info_ptr (I_rel_opening_id, vrm_open_info_ptr, code); if code ^= 0 then call error (code); vrm_rel_desc_ptr = vrm_open_info.relation_model_ptr; vrm_com_ptr = vrm_open_info.com_ptr; found = "0"b; do i = 1 to vrm_open_info.number_of_index_collections while (^found); if vrm_open_info.index_collection (i).id = I_index_collection_id then do; found = "1"b; collection_index = i; vrm_collection_info_ptr = vrm_open_info.index_collection (i).info_ptr; end; end; if ^found then call error (dm_error_$collection_not_in_relation); change_bits_ptr, key_list_ptr, scan_iocb_ptr, index_iocb_ptr, get_key_info_ptr, pk_iocb_ptr = null; on cleanup call tidy_up; call init_destroy; call iox_$position (index_iocb_ptr, -1, 0, code); /* -1 = goto beginning of file */ if code ^= 0 then call error (code); index_head = ""; unspec (index_head) = vrm_rel_desc.rel_id || vrm_collection_info.id || "0000000"b; seek_head_info.search_key = index_head; call iox_$control (index_iocb_ptr, "seek_head", addr (seek_head_info), code); if code ^= 0 then do; /* check for empty relation */ if code ^= error_table_$no_record then call error (code); call tidy_up; goto Exit; end; key_found = index_head; do while (substr (key_found, 1, 3) = index_head & code = 0); call iox_$control (index_iocb_ptr, "delete_key", null (), code); if code ^= 0 then call error (code); call iox_$read_key (index_iocb_ptr, key_found, (0), code); if code ^= 0 then if code ^= error_table_$end_of_info then call error (code); end; call remove_collection_info; vrm_rel_desc.number_sec_indexes = vrm_rel_desc.number_sec_indexes - 1; if ^vrm_rel_desc.MRDS_compatible then do; /* delete index record */ end; O_code = 0; call tidy_up; /* do non-local goto */ %page; init_create: proc; call open_iocb (KSQU, "vrm_add_index", index_iocb_ptr); call open_iocb (KSQR, "vrm_scan_records", scan_iocb_ptr); call setup_for_relation_scan (scan_iocb_ptr); cb_number_of_change_bits = vrm_rel_desc.number_attrs; allocate change_bits set (change_bits_ptr); string (change_bits.position) = "0"b; change_bits.position (attr_no) = "1"b; kl_number_of_keys = 1; allocate key_list set (key_list_ptr); file_id = vrm_rel_desc.file_id; end init_create; init_destroy: proc; call open_iocb (KSQU, "vrm_delete_index", index_iocb_ptr); call open_iocb (KSQR, "vrm_scan_records", scan_iocb_ptr); call setup_for_relation_scan (scan_iocb_ptr); cb_number_of_change_bits = vrm_rel_desc.number_attrs; allocate change_bits set (change_bits_ptr); string (change_bits.position) = "0"b; do i = 1 to vrm_collection_info.number_of_attributes; attr_no = vrm_collection_info.attribute (i).attr_index; change_bits.position (attr_no) = "1"b; end; kl_number_of_keys = 1; allocate key_list set (key_list_ptr); file_id = vrm_rel_desc.file_id; index_value_length = 0; /* keep the compiler happy */ dcl (i, attr_no) fixed bin; end init_destroy; %page; open_iocb: proc (open_mode, open_name, iocb_ptr); dcl open_mode fixed bin (17) parameter; dcl open_name char (24) varying parameter; dcl iocb_ptr ptr parameter; dcl atd char (344) varying; dcl attach_desc char (344); dcl code fixed bin (35); atd = "vfile_ " || rtrim (vrm_open_info.database_dir_path); atd = atd || ">"; atd = atd || rtrim (vrm_open_info.relation_name); atd = atd || " -dup_ok -share "; atd = atd || ltrim (char (vrm_data_$max_vfile_wait_time)); if vrm_rel_desc.switches.stationary_records then atd = atd || " -stationary"; attach_desc = atd; call iox_$attach_name (unique_chars_ ("0"b) || open_name, iocb_ptr, rtrim (attach_desc), null (), code); if code ^= 0 then call error (code); call iox_$open (iocb_ptr, open_mode, "0"b, code); if code ^= 0 then call error (code); end open_iocb; %page; setup_for_relation_scan: proc (sfrs_rel_scan_iocb_ptr); /* This routine sets up the beginning of the primary key so that the get_a_tuple routine can be called to get each record in turn */ /* PARAMETERS */ dcl sfrs_rel_scan_iocb_ptr ptr; /* (input) pointer to the iocb that will be used to . scan all the tuples in the relation */ /* AUTOMATIC */ dcl sfrs_code fixed bin (35); call iox_$position (sfrs_rel_scan_iocb_ptr, -1, 0, sfrs_code); /* goto beginning of file */ if sfrs_code = 0 then do; seek_head_info.relation_type = 0; /* equal */ seek_head_info.n = 3; /* 3 chars */ addr (seek_head_info.search_key) -> index.rel_id = vrm_rel_desc.rel_id; addr (seek_head_info.search_key) -> index.index_id = "0"b; /* primary key */ addr (seek_head_info.search_key) -> index.mbz = "0"b; call iox_$control (sfrs_rel_scan_iocb_ptr, "seek_head", addr (seek_head_info), sfrs_code); end; if sfrs_code ^= 0 & sfrs_code ^= error_table_$no_record then call error (sfrs_code); gk_key_len = 256; allocate gk_info set (get_key_info_ptr); unspec (get_key_info_ptr -> gk_info.flags) = "0"b; get_key_info_ptr -> gk_info.flags.current = "1"b; get_key_info_ptr -> gk_info.flags.reset_pos = "0"b; allocate rs_info set (rs_info_ptr); rs_info.version = rs_info_version_2; string (rs_info.flags) = "0"b; return; end setup_for_relation_scan; %page; get_a_tuple: proc (gat_rel_scan_iocb_ptr, gat_file_id, gat_tid, gat_tuple_ptr); /* This routine determines a pointer to the next tuple and the tuple's tuple id which is based on the vfile record descriptor for the record which contains the tuple. The tuple_id and vfile descriptor are different for historical reasons. */ /* PARAMETERS */ dcl gat_rel_scan_iocb_ptr ptr; /* (input) pointer to the iocb that will be used to . scan all the tuples in the relation */ dcl gat_file_id bit (7); /* (input) id of the file as defined in the database model */ dcl gat_tid bit (36) aligned; /* (output) a tuple id */ dcl gat_tuple_ptr ptr; /* (output) pointer to a tuple */ /* AUTOMATIC */ dcl gat_code fixed bin (35); /* local error code */ dcl tid_ptr pointer; /* Pointer to tid structure */ dcl vfd_ptr pointer; /* Pointer to vfd structure */ /* BASED */ dcl 1 tid aligned based (tid_ptr), /* MRDS tuple id (tid) */ 2 non_std_desc bit (1) unal, /* Non-standard descriptor bit */ 2 temp bit (1) unal, /* On if temp relation */ 2 file_id bit (7) unal, /* File id from mrds db_model file_id_list */ 2 comp_num bit (10) unal, /* Component number */ 2 offset bit (17) unal; /* Offset within component */ dcl 1 vfd aligned based (vfd_ptr), /* Vfile desc */ 2 pad_1 bit (8) unal, 2 comp_number bit (10) unal, /* Component number */ 2 comp_offset bit (17) unal, /* Offset with in component */ 2 pade_2 bit (1) unal; call iox_$control (gat_rel_scan_iocb_ptr, "get_key", get_key_info_ptr, gat_code); if gat_code ^= 0 then do; if gat_code = error_table_$end_of_info | gat_code = error_table_$no_record then gat_tuple_ptr = null (); else call error (gat_code); end; else do; call iox_$control (gat_rel_scan_iocb_ptr, "record_status", addr (rs_info), gat_code); if gat_code ^= 0 then call error (gat_code); else do; /* Convert vfile_descriptor to tuple_id (tid) */ vfd_ptr = addr (rs_info.descriptor); tid_ptr = addr (gat_tid); tid.non_std_desc = "1"b; tid.temp = "0"b; tid.file_id = gat_file_id; tid.comp_num = vfd.comp_number; tid.offset = vfd.comp_offset; gat_tuple_ptr = rs_info.record_ptr; call iox_$position (gat_rel_scan_iocb_ptr, 0, 1, gat_code); /* skip 1 record */ end; end; return; end get_a_tuple; %page; fill_attribute_info: proc; key_offset = 0; do i = 1 to id_list.number_of_ids; attr_no = id_list.id (i); desc_ptr = addr (vrm_rel_desc.attr (attr_no).descriptor); call vrmu_encode_key$compute_alignment_and_length (desc_ptr, key_offset, key_alignment, key_bit_len); key_offset = key_offset + key_alignment; vrm_collection_info.attribute (i).attr_index = attr_no; vrm_collection_info.attribute (i).key_offset = key_offset; vrm_collection_info.attribute (i).key_bit_len = key_bit_len; key_offset = key_offset + key_bit_len; end; /* do i */ dcl attr_no fixed bin; dcl i fixed bin; dcl key_alignment fixed bin; dcl key_bit_len fixed bin; dcl key_offset fixed bin; end fill_attribute_info; %page; calculate_collection_id: proc (attr_no, O_id); /* This procedure obtains a unassigned collection id and returns it as O_id */ dcl attr_no fixed bin (17) parameter; dcl O_id bit (36) aligned parameter; dcl j fixed bin; dcl available bit (1) init ("0"b); dcl found bit (1); dcl candidate_id bit (36) aligned based (addr (id_structure)); dcl 1 id_structure aligned, 2 index_no fixed bin (8) uns unal, 2 pad bit (28) unal init ("0"b); do id_structure.index_no = 1 to 255 while (^available); found = "0"b; do j = 1 to vrm_open_info.number_of_index_collections; if vrm_open_info.index_collection (j).id = candidate_id then found = "1"b; end; /* do j = 1 */ if ^found then do; /* got it */ O_id = candidate_id; available = "1"b; end; /* if ^found */ end; /* do 1 to 255 */ if ^available then call error (mdbm_error_$max_indexes); end calculate_collection_id; %page; add_collection_info: proc; dcl old_vrm_open_info_ptr ptr; voi_no_of_index_collections = vrm_open_info.number_of_index_collections + 1; old_vrm_open_info_ptr = vrm_open_info_ptr; allocate vrm_open_info in (wa) set (vrm_open_info_ptr); vrm_open_info.number_of_index_collections = vrm_open_info.number_of_index_collections - 1; /* So we can copy old info */ vrm_open_info_ptr -> vrm_open_info = old_vrm_open_info_ptr -> vrm_open_info; vrm_open_info.number_of_index_collections = vrm_open_info.number_of_index_collections + 1; /* Original value */ vrm_open_info.index_collection (voi_no_of_index_collections).id = O_index_collection_id; vrm_open_info.index_collection (voi_no_of_index_collections).info_ptr = vrm_collection_info_ptr; call vrm_open_man$set_open_info_ptr (vrm_open_info.opening_id, vrm_open_info_ptr); free old_vrm_open_info_ptr -> vrm_open_info in (wa); end add_collection_info; %page; remove_collection_info: proc; vrm_collection_info_ptr = vrm_open_info.index_collection (collection_index).info_ptr; attr_no = vrm_collection_info.attribute (1).attr_index; vrm_open_info.index_collection (collection_index).id = "0"b; vrm_open_info.index_collection (collection_index).info_ptr = null (); end remove_collection_info; %page; tidy_up: proc; if index_iocb_ptr ^= null () then call close_iocb (index_iocb_ptr); if scan_iocb_ptr ^= null () then call close_iocb (scan_iocb_ptr); if pk_iocb_ptr ^= null () then call close_iocb (pk_iocb_ptr); if change_bits_ptr ^= null () then free change_bits; if key_list_ptr ^= null () then free key_list; if get_key_info_ptr ^= null () then free get_key_info_ptr -> gk_info; if rs_info_ptr ^= null () then free rs_info; end tidy_up; close_iocb: proc (iocb_ptr); dcl iocb_ptr ptr parameter; dcl code fixed bin (35); call iox_$close (iocb_ptr, code); call iox_$detach_iocb (iocb_ptr, code); /* ignore code */ call iox_$destroy_iocb (iocb_ptr, code); end close_iocb; error: proc (ecode); dcl ecode fixed bin (35); O_code = ecode; go to Exit; end error; %page; %include vrm_open_info; %page; %include vrm_rel_desc; %page; %include vrm_collection_info; %page; %include vrm_com; %page; %include dm_id_list; %page; %include vrm_tuple; %page; %include vrm_change_bits; %page; %include vrm_key_list; %page; %include vrm_index; %page; %include ak_info; %page; %include rs_info; %page; /* Area */ dcl wa area based (vrm_com.work_area_ptr); /* Automatic */ dcl attr_no fixed bin (17); dcl code fixed bin (35); dcl collection_index fixed bin; dcl file_id bit (7); dcl found bit (1) aligned; dcl get_key_info_ptr ptr; dcl i fixed bin (17); dcl index_iocb_ptr ptr; dcl index_head char (3); dcl key_found char (256) varying; dcl pk_iocb_ptr ptr; dcl scan_iocb_ptr ptr; dcl tuple_id bit (36) aligned; dcl ax fixed bin; dcl x fixed bin; /* Builtin */ dcl (addr, char, currentsize, fixed, ltrim, null, rel, rtrim, string, substr, unspec ) builtin; /* Condition */ dcl cleanup condition; /* Internal static */ dcl KSQR fixed bin (17) int static init (8); dcl KSQU fixed bin (17) int static init (10); /* External entries */ dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl iox_$destroy_iocb entry (ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)); dcl iox_$position entry (ptr, fixed bin, fixed bin (21), fixed bin (35)); dcl iox_$read_key entry (ptr, char (256) var, fixed bin (21), fixed bin (35)); dcl iox_$seek_key entry (ptr, char (256) var, fixed bin (21), fixed bin (35)); dcl iox_$write_record entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl unique_chars_ entry (bit (*)) returns (char (15)); dcl vrm_open_man$get_open_info_ptr entry (bit (36) aligned, ptr, fixed bin (35)); dcl vrm_open_man$set_open_info_ptr entry (bit (36) aligned, ptr); dcl vrmu_add_indexes entry (ptr, ptr, bit (36) aligned, fixed bin (35)); dcl vrmu_build_index_list entry (ptr, ptr, ptr, ptr, ptr, fixed bin (35)); dcl vrmu_encode_key$compute_alignment_and_length entry (ptr, fixed bin, fixed bin, fixed bin); /* External static */ dcl ( error_table_$unimplemented_version, error_table_$end_of_info, error_table_$no_record, mdbm_error_$max_indexes, dm_error_$collection_not_in_relation, sys_info$max_seg_size, vrm_data_$max_vfile_wait_time ) ext static fixed bin (35); /* Structure */ dcl 1 flags aligned, 2 relation_must_be_empty bit (1) unal, 2 index_is_clustering bit (1) unal, 2 index_is_unique bit (1) unal, 2 pad bit (33) unal; dcl 1 seek_head_info, 2 relation_type fixed bin, 2 n fixed bin, 2 search_key char (3); dcl desc_ptr ptr; dcl 1 descriptor based (desc_ptr), 2 version bit (1) unal, 2 type fixed bin (6) unsigned unal, 2 packed bit (1) unal, 2 number_dims bit (4) unal, 2 size fixed bin (24) unsigned unal; end create_index;  vrm_meter.pl1 11/23/84 0800.9rew 11/21/84 0933.8 318654 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ vrm_meter: vrmm: proc; if saved_meter_seg_ptr = null then do; call get_temp_segment_ (PROC_NAME, saved_meter_seg_ptr, code); if code ^= 0 then call error (code, "^/Getting temp segment"); meter_info_ptr = saved_meter_seg_ptr; meter_info.work_area = empty (); /* Make it an area */ meter_info.meter_on = "1"b; meter_info.all_sw = "1"b; meter_info.num_rels = 0; end; else meter_info_ptr = saved_meter_seg_ptr; print_long_sw = "0"b; reset_sw = "0"b; delete_sw = "0"b; print_sw = "0"b; list_sw = "0"b; meter_on_sw = "0"b; /* Default */ on_arg = "0"b; meter_sw = "0"b; all_rel_arg = "0"b; all_rel_sw = "0"b; reset_all_sw = "1"b; /* Default */ reset_sw = "0"b; call cu_$arg_count (nargs, code); if code ^= 0 then call error (code, "^/Getting arg count"); if nargs < 1 then call error (error_table_$wrong_no_of_args, "^/vrmm -list_meters^23t| -lsm ^/^7x-reset_meters^23t| -rsm ^/^7x-print_meters^23t| -prm ^/^7x-meter^23t| -mt ^/^7x-delete_meters^23t| -dlm ^/"); %page; do n = 1 to nargs; call get_arg (n); if substr (arg, 1, 1) = "-" then do; /* Check control arg */ if arg = "-list_meters" | arg = "-lsm" | arg = "-ls" then do; list_sw = "1"b; call process_list_args (n); end; else if arg = "-mt" | arg = "-meter" then do; meter_sw = "1"b; call process_meter_args (n); end; else if arg = "-reset_meters" | arg = "-rsm" | arg = "-rs" then do; reset_sw = "1"b; call process_reset_args (n); end; else if arg = "-print_meters" | arg = "-pm" | arg = "-prm" then do; print_sw = "1"b; call process_print_args (n); end; else if arg = "-delete_meters" | arg = "-dlm" | arg = "-dl" then do; delete_sw = "1"b; call process_delete_args (n); end; else call error (error_table_$bad_subr_arg, arg); end; /* Check control args */ else call error (error_table_$bad_arg, arg); end; /* END do n = 1 to nargs */ if meter_sw then call meter; if list_sw then call list; if print_sw then call print; if reset_sw then call reset; if delete_sw then call delete; exit: return; %page; /* * * * * * * * * * std_args * * * * * * * * * * * * * * * * * * * * */ std_args: proc (sn, arg_str_ptr, used_sw); dcl sn fixed bin parameter; /* Arg number */ dcl arg_str_ptr ptr parameter; /* Argument structure to be used */ dcl used_sw bit (1) parameter; std_arg_ptr = arg_str_ptr; used_sw = "0"b; if arg = "-all" | arg = "-a" then do; std_arg.all_sw = "1"b; used_sw = "1"b; sn = sn + 1; end; else if arg = "-path" | arg = "-pn" then do; sn = sn + 1; used_sw = "1"b; if sn + 1 > nargs then call error (error_table_$noarg, "^/A pathname missing following " || arg || "."); call get_arg (sn + 1); if substr (arg, 1, 1) = "-" then call error (error_table_$bad_arg, "^/Expected pathname missing following -path control arg."); else do; call get_path_desc (arg, addr (std_arg)); std_arg.desc_sw = "1"b; end; sn = sn + 1; end; /* END -path */ end std_args; %page; process_list_args: proc (ln); dcl ln fixed bin parameter; unspec (list_arg) = "0"b; if ln + 1 > nargs then do; list_arg.all_sw = "1"b; return; end; list_args_done = "0"b; do while (^list_args_done); if ln + 1 <= nargs then call get_arg (ln + 1); else return; if substr (arg, 1, 1) = "-" then do; call std_args (ln, addr (list_arg), arg_used); list_args_done = ^arg_used; end; else list_args_done = "1"b; end; end process_list_args; %page; process_meter_args: proc (mn); dcl mn fixed bin parameter; unspec (meter_arg) = "0"b; if mn + 1 > nargs then return; meter_args_done = "0"b; do while (^meter_args_done); if mn + 1 <= nargs then call get_arg (mn + 1); else return; if substr (arg, 1, 1) = "-" then do; used_it_sw = "0"b; call std_args (mn, addr (meter_arg), used_it_sw); if used_it_sw then meter_args_done = "0"b; else if arg = "-on" then do; on_arg = "1"b; meter_on_sw = "1"b; mn = mn + 1; end; else if arg = "-off" then do; on_arg = "1"b; meter_on_sw = "0"b; mn = mn + 1; end; else meter_args_done = "1"b; end; else meter_args_done = "1"b; end; end process_meter_args; %page; /* * * * * * * * * * * * * * process_delete_args * * * * * * * * * * */ process_delete_args: proc (dn); dcl dn fixed bin parameter; unspec (delete_arg) = "0"b; if dn + 1 > nargs then do; delete_arg.all_sw = "1"b; return; end; delete_args_done = "0"b; do while (^delete_args_done); if dn + 1 <= nargs then call get_arg (dn + 1); else return; if substr (arg, 1, 1) = "-" then do; call std_args (dn, addr (delete_arg), arg_used); delete_args_done = ^arg_used; end; else delete_args_done = "1"b; end; end process_delete_args; %page; process_reset_args: proc (rn); dcl rn fixed bin parameter; unspec (reset_arg) = "0"b; if rn + 1 > nargs then do; reset_arg.all_sw = "1"b; return; end; reset_args_done = "0"b; do while (^reset_args_done); if rn + 1 <= nargs then call get_arg (rn + 1); else return; if substr (arg, 1, 1) = "-" then do; call std_args (rn, addr (reset_arg), arg_used); reset_args_done = ^arg_used; end; else reset_args_done = "1"b; end; end process_reset_args; %page; process_print_args: proc (dn); dcl dn fixed bin parameter; print_search_stat_sw = "0"b; print_search_stat_arg_sw = "0"b; print_last_call_arg_sw = "0"b; print_last_call_sw = "0"b; print_total_sw = "0"b; print_total_arg_sw = "0"b; print_long_sw = "0"b; unspec (meter_arg) = "0"b; if dn + 1 > nargs then do; print_long_sw = "1"b; return; end; print_args_done = "0"b; do while (^print_args_done); if dn + 1 <= nargs then call get_arg (dn + 1); else return; if substr (arg, 1, 1) = "-" then do; used_it_sw = "0"b; call std_args (dn, addr (print_arg), used_it_sw); if used_it_sw then print_args_done = "0"b; else if arg = "-last_call" | arg = "-last" then do; print_last_call_arg_sw = "1"b; print_last_call_sw = "1"b; dn = dn + 1; end; else if arg = "-total" | arg = "-tt" then do; print_total_sw = "1"b; print_total_arg_sw = "1"b; dn = dn + 1; end; else if arg = "-search" | arg = "-sch" then do; print_search_stat_sw = "1"b; print_search_stat_arg_sw = "1"b; dn = dn + 1; end; else if arg = "-long" | arg = "-lg" then do; print_long_sw = "1"b; dn = dn + 1; end; else if arg = "-brief" | arg = "-bf" then do; print_long_sw = "0"b; dn = dn + 1; end; else print_args_done = "1"b; end; else print_args_done = "1"b; end; end process_print_args; %page; add_meter: entry (I_cursor_ptr, O_meter_ptr, O_code); dcl I_cursor_ptr ptr parameter; /* Pointer to vrm_cursor to be added */ dcl O_meter_ptr ptr parameter; /* Pointer to vrm_meter */ dcl O_code fixed bin (35) parameter; /* Error code */ O_code = 0; O_meter_ptr = null; meter_info_ptr = saved_meter_seg_ptr; vrm_cursor_ptr = I_cursor_ptr; vrm_open_info_ptr = vrm_cursor.open_info_ptr; vrm_rel_desc_ptr = vrm_cursor.vrm_relation_desc_ptr; call get_path_desc (rtrim (vrm_open_info.database_dir_path) || ">" || vrm_open_info.relation_name, addr (meter_arg)); x = locate_uid_in_rel_list (meter_arg.path_desc.uid, 0); if x = 0 then do; if ^meter_info.meter_on then goto add_meter_exit; meter_arg.path_desc.dir = vrm_open_info.database_dir_path; meter_arg.path_desc.ent = vrm_open_info.relation_name; meter_arg.path_desc.uid = vrm_open_info.file_uid; call add_rel_list_ent (addr (meter_arg), x); end; call add_meter_entry (x, vrm_cursor_ptr, vrm_meter_ptr, code); if code = 0 then O_meter_ptr = vrm_meter_ptr; else O_code = code; /* end; */ add_meter_exit: return; %page; add_rel_list_ent: proc (I_arg_ptr, O_rl_ix); dcl I_arg_ptr ptr parameter; dcl O_rl_ix fixed bin parameter; dcl rl_ix fixed bin; std_arg_ptr = I_arg_ptr; if meter_info.num_rels = MAX_RELS then call sub_error (error_table_$too_many_names); O_rl_ix, rl_ix = meter_info.num_rels + 1; meter_info.num_rels = rl_ix; meter_info.rel_info (rl_ix).rel_name = std_arg.path_desc.ent; meter_info.rel_info (rl_ix).rel_dir = std_arg.path_desc.dir; meter_info.rel_info (rl_ix).number_meters = 0; meter_info.rel_info (rl_ix).uid = std_arg.path_desc.uid; meter_info.rel_info (rl_ix).meter_ptrs (*) = null; end add_rel_list_ent; %page; add_meter_entry: proc (I_ame_rel_list_ix, I_ame_cursor_ptr, O_vrm_meter_ptr, O_code); dcl I_ame_cursor_ptr ptr parameter; dcl I_ame_rel_list_ix fixed bin parameter; dcl O_vrm_meter_ptr ptr parameter; dcl O_code fixed bin (35) parameter; O_vrm_meter_ptr = null; O_code = 0; rx = I_ame_rel_list_ix; if meter_info.rel_info (rx).number_meters > 4 then O_code = error_table_$too_many_names; else do; allocate vrm_meter in (meter_info.work_area) set (vrm_meter_ptr); meter_info.rel_info (rx).number_meters = meter_info.rel_info (rx).number_meters + 1; vrm_meter.cursor_name = ltrim (char (meter_info.rel_info (rx).number_meters)); vrm_meter.meter_start_time = clock; vrm_meter.switches.metering = "0"b; vrm_meter.last_call_stats = 0; vrm_meter.total_stats = 0; meter_info.rel_info (rx).meter_ptrs (meter_info.rel_info (rx).number_meters) = vrm_meter_ptr; vrm_meter.cursor_ptr = I_ame_cursor_ptr;/* May be null */ O_vrm_meter_ptr = vrm_meter_ptr; end; end add_meter_entry; %page; delete_rel_list_ent: proc (I_rel_ix); dcl I_rel_ix fixed bin parameter; rx = I_rel_ix; if meter_info.num_rels < rx then return; do mx = 1 to meter_info.rel_info (rx).number_meters; vrm_meter_ptr = meter_info.rel_info (rx).meter_ptrs (mx); if vrm_meter.cursor_ptr ^= null then do; vrm_meter.cursor_ptr -> vrm_cursor.meter_sw = "0"b; vrm_meter.cursor_ptr -> vrm_cursor.meter_ptr = null; end; free vrm_meter in (meter_info.work_area); end; do dx = rx to meter_info.num_rels - 1; meter_info.rel_info (dx) = meter_info.rel_info (dx + 1); end; meter_info.num_rels = meter_info.num_rels - 1; end delete_rel_list_ent; %page; /* * * * * * * * * * * * * meter * * * * * * * * * * * * * * * */ meter: proc; if ^meter_arg.all_sw & ^meter_arg.desc_sw & ^on_arg then do; meter_arg.all_sw = "1"b; meter_on_sw = "1"b; end; if ^meter_arg.desc_sw then meter_arg.all_sw = "1"b; if ^on_arg then meter_on_sw = "1"b; if meter_on_sw then meter_starting_time = clock; if meter_arg.all_sw then do; /* Turn um all on */ if meter_arg.desc_sw then call error (error_table_$bad_arg, "^/ The -all and -path control arguments cannot be used together."); meter_info.all_sw = meter_on_sw; meter_info.meter_on = meter_on_sw; if meter_on_sw then call vrm_create_cursor$metering_on; else call vrm_create_cursor$metering_off; do i = 1 to meter_info.num_rels; do c = 1 to meter_info.rel_info (i).number_meters; vrm_meter_ptr = meter_info.rel_info (i).meter_ptrs (c); vrm_meter.switches.metering = meter_on_sw; if vrm_meter.cursor_ptr ^= null then vrm_meter.cursor_ptr -> vrm_cursor.switches.meter_sw = meter_on_sw; if meter_on_sw & vrm_meter.meter_start_time = 0 then vrm_meter.meter_start_time = meter_starting_time; end; /* END do c = 1 to */ end; /* END do i = 1 to */ end; /* END if meter_all */ %page; else do; /* Meter specific one */ x = 0; if meter_arg.desc_sw then do; x = locate_uid_in_rel_list (meter_arg.path_desc.uid, 1); if x ^= 0 then do; do c = 1 to meter_info.rel_info (x).number_meters; vrm_meter_ptr = meter_info.rel_info (x).meter_ptrs (c); vrm_meter.switches.metering = meter_on_sw; if vrm_meter.cursor_ptr ^= null then do; vrm_meter.switches.metering = meter_on_sw; vrm_meter.cursor_ptr -> vrm_cursor.switches.meter_sw = meter_on_sw; end; end; /* END do c = 1 to */ end; /* END if x ^= 0 then do; */ else do; call add_rel_list_ent (addr (meter_arg), x); call add_meter_entry (x, null, vrm_meter_ptr, code); if code ^= 0 then call error (code, "Adding meter cursor name: " || meter_arg.relation_name); vrm_meter.switches.metering = "1"b; end; /* END do while (x ^= 0 ) */ end; /* if meter_arg.desc_sw then do */ end; /* END else do */ end meter; %page; /* * * * * * * * * * * * * * list * * * * * * * * * * * * * * */ list: proc; if ^list_arg.desc_sw then list_arg.all_sw = "1"b; if list_arg.all_sw then do; if list_arg.desc_sw then call error (error_table_$bad_arg, "^/ The -all and -path control arguments cannot be used together."); if meter_info.all_sw & meter_info.meter_on then call ioa_ ("^/^-New cursors will be metered.^/"); else if ^meter_info.meter_on then call ioa_ ("^/^-New cursors will not be metered.^/"); if meter_info.num_rels < 1 then call ioa_ ("^-None have been specified.^/"); else do l = 1 to meter_info.num_rels; call list_display (l); end; end; /* END if list_arg.all_sw */ else do; /* Meter specific one */ listed_one = "0"b; x = 1; do while (x ^= 0 & x <= meter_info.num_rels); if list_arg.desc_sw then x = locate_uid_in_rel_list (list_arg.path_desc.uid, x); if x ^= 0 then do; call list_display (x); x = x + 1; end; end; /* END do while (x ^= 0 ) */ if ^listed_one then call ioa_ ("Specified meter to be listed does not exists."); end; /* END else do */ call ioa_ (""); %page; list_display: proc (ml); dcl ld fixed bin; dcl ml fixed bin parameter; list_path = get_shortest_path_ (meter_info.rel_info (ml).rel_dir); call ioa_ ("RELATION:^20t^a>^a", list_path, meter_info.rel_info (ml).rel_name); if meter_info.rel_info (ml).number_meters = 0 then do; /* Nothing to display */ call ioa_ ("^20tNo cursors defined for this relation.^/"); return; end; do ld = 1 to meter_info.rel_info (ml).number_meters; vrm_meter_ptr = meter_info.rel_info (ml).meter_ptrs (ld); if vrm_meter.switches.metering then data = "Metering ON "; else data = "Metering OFF "; if vrm_meter.last_call_stats.last_time_of_stats = 0 then data = data || "No meters"; else do; call format_time (vrm_meter.last_call_stats.last_time_of_stats, time); data = data || "Last meter time was " || time; end; call ioa_ ("^5xCURSOR:^20t^a ^a", vrm_meter.cursor_name, data); listed_one = "1"b; end; /* do ld = 1 to meter_list.number_meters */ end list_display; end list; %page; /* * * * * * * * * * * * print * * * * * * * * * * * * * */ print: proc; if print_long_sw then do; print_total_sw = "1"b; print_last_call_sw = "1"b; print_search_stat_sw = "1"b; end; printed_one = "0"b; if ^print_total_sw & ^print_last_call_sw then print_last_call_sw = "1"b; if ^print_arg.desc_sw then print_arg.all_sw = "1"b; if print_arg.all_sw then do; /* Display um all */ do i = 1 to meter_info.num_rels; last_print_path = ""; do c = 1 to meter_info.rel_info (i).number_meters; vrm_meter_ptr = meter_info.rel_info (i).meter_ptrs (c); call print_stats (i, vrm_meter_ptr); end; /* END do c = 1 to */ end; /* END do i = 1 to */ end; /* END if print_arg.all_sw */ else do; /* Specific realtion */ x = 1; do while (x ^= 0 & x <= meter_info.num_rels); if print_arg.desc_sw then x = locate_uid_in_rel_list (print_arg.path_desc.uid, x); if x ^= 0 then do; last_print_path = ""; do c = 1 to meter_info.rel_info (x).number_meters; call print_stats (x, meter_info.rel_info (x).meter_ptrs (c)); end; x = x + 1; end; /* END x ^= 0 */ end; /* END do while x ^= 0 */ end; /* END Specific relation */ if ^printed_one then call ioa_ ("^/No meters were found."); end print; %page; /* * * * * * * * * * * print_stats * * * * * * * * * * * * * * */ print_stats: proc (I_rel_ix, I_meter_ptr); dcl I_rel_ix fixed bin parameter; dcl I_meter_ptr ptr parameter; vrm_meter_ptr = I_meter_ptr; if vrm_meter.last_call_stats.last_time_of_stats = 0 then return; print_path = get_shortest_path_ (meter_info.rel_info (I_rel_ix).rel_dir); print_path = rtrim (print_path) || ">" || meter_info.rel_info (I_rel_ix).rel_name; if last_print_path ^= print_path then do; call ioa_ ("^/RELATION:^22t^a", print_path); last_print_path = print_path; end; printed_one = "1"b; if print_last_call_sw then lc = "1"b; else lc = "0"b; if print_total_sw then do; tt = "1"b; if lc then tot_ptr = addr (s.s2); else tot_ptr = addr (s.s1); end; else tt = "0"b; call print_the_meters; end print_stats; %page; /* * * * * * * * * * * * * * * * print_the_meters * * * * * * * * * * * */ print_the_meters: proc; call ioa_ ("^/ METERS FOR CURSOR:^32t^a^/", vrm_meter.cursor_name); s = ""; if lc then last = "LAST CALL METERS"; if tt then tot = " TOTAL METERS"; call ioa_ ("^a^/", string (s)); s = ""; s.h = "Metering time:"; if lc then call format_time (vrm_meter.last_call_stats.last_time_of_stats, last); if tt then call format_time (vrm_meter.meter_start_time, tot); call ioa_ ("^a", string (s)); s = ""; s.h = "VCPU (seconds):"; if lc then call format_vcpu (vrm_meter.last_call_stats.vcpu_time, last); if tt then call format_vcpu (vrm_meter.total_stats.vcpu_time, tot); call ioa_ ("^a", string (s)); s = ""; s.h = "Page faults:"; if lc then call format_val (vrm_meter.last_call_stats.page_faults, last); if tt then call format_val (vrm_meter.total_stats.page_faults, tot); call ioa_ ("^a", string (s)); s = ""; s.h = "Number times locked:"; if lc then call format_val (vrm_meter.last_call_stats.number_times_locked, last); if tt then call format_val (vrm_meter.total_stats.number_times_locked, tot); call ioa_ ("^a", string (s)); s = ""; s.h = "Number times used:"; if lc then call format_val (vrm_meter.last_call_stats.number_times_used, last); if tt then call format_val (vrm_meter.total_stats.number_times_used, tot); call ioa_ ("^a^/", string (s)); if print_search_stat_sw then do; if (lc & vrm_meter.last_call_stats.seek_heads ^= 0) | tt then do; s = ""; s.h = "Regular seek heads:"; if lc then call format_val (vrm_meter.last_call_stats.seek_heads, last); if tt then call format_val (vrm_meter.total_stats.seek_heads, tot); call ioa_ ("^a", string (s)); end; if (lc & vrm_meter.last_call_stats.special_seek_heads ^= 0) | tt then do; s = ""; s.h = "Special seek heads:"; if lc then call format_val (vrm_meter.last_call_stats.special_seek_heads, last); if tt then call format_val (vrm_meter.total_stats.special_seek_heads, tot); call ioa_ ("^a", string (s)); end; if (lc & vrm_meter.last_call_stats.keys_read ^= 0) | tt then do; s = ""; s.h = "Keys read:"; if lc then call format_val (vrm_meter.last_call_stats.keys_read, last); if tt then call format_val (vrm_meter.total_stats.keys_read, tot); call ioa_ ("^a", string (s)); end; if (lc & vrm_meter.last_call_stats.keys_compared ^= 0) | tt then do; s = ""; s.h = "Keys comparisons:"; if lc then call format_val (vrm_meter.last_call_stats.keys_compared, last); if tt then call format_val (vrm_meter.total_stats.keys_compared, tot); call ioa_ ("^a", string (s)); end; if (lc & vrm_meter.last_call_stats.key_hits ^= 0) | tt then do; s = ""; s.h = "Key hits:"; if lc then call format_val (vrm_meter.last_call_stats.key_hits, last); if tt then call format_val (vrm_meter.total_stats.key_hits, tot); call ioa_ ("^a", string (s)); end; s = ""; s.h = "Upper limit found:"; if lc then do; if vrm_meter.last_call_stats.upper_limit_found_count > 0 then last = "YES"; else last = "NO"; end; if tt then call format_val (vrm_meter.total_stats.upper_limit_found_count, tot); call ioa_ ("^a", string (s)); if (lc & vrm_meter.last_call_stats.num_times_search_called ^= 0) | tt then do; s = ""; s.h = "Search called:"; if lc then call format_val (vrm_meter.last_call_stats.num_times_search_called, last); if tt then call format_val (vrm_meter.total_stats.num_times_search_called, tot); call ioa_ ("^a", string (s)); end; if (lc & vrm_meter.last_call_stats.records_searched ^= 0) | tt then do; s = ""; s.h = "Records searched:"; if lc then call format_val (vrm_meter.last_call_stats.records_searched, last); if tt then call format_val (vrm_meter.total_stats.records_searched, tot); call ioa_ ("^a", string (s)); end; if (lc & vrm_meter.last_call_stats.non_key_compares ^= 0) | tt then do; s = ""; s.h = "Non-key compares:"; if lc then call format_val (vrm_meter.last_call_stats.non_key_compares, last); if tt then call format_val (vrm_meter.total_stats.non_key_compares, tot); call ioa_ ("^a", string (s)); end; if (lc & vrm_meter.last_call_stats.non_key_hits ^= 0) | tt then do; s = ""; s.h = "Non-key hits:"; if lc then call format_val (vrm_meter.last_call_stats.non_key_hits, last); if tt then call format_val (vrm_meter.total_stats.non_key_hits, tot); call ioa_ ("^a", string (s)); end; s = ""; s.h = "Items returned:"; if lc then call format_val (vrm_meter.last_call_stats.number_items_returned, last); if tt then call format_val (vrm_meter.total_stats.number_items_returned, tot); call ioa_ ("^a", string (s)); s = ""; s.h = "Tuples deleted:"; if lc then call format_val (vrm_meter.last_call_stats.number_tuples_deleted, last); if tt then call format_val (vrm_meter.total_stats.number_tuples_deleted, tot); call ioa_ ("^a", string (s)); s = ""; s.h = "Tuples modified:"; if lc then call format_val (vrm_meter.last_call_stats.number_tuples_modified, last); if tt then call format_val (vrm_meter.total_stats.number_tuples_modified, tot); call ioa_ ("^a", string (s)); s = ""; s.h = "Tuples stored:"; if lc then call format_val (vrm_meter.last_call_stats.number_tuples_stored, last); if tt then call format_val (vrm_meter.total_stats.number_tuples_stored, tot); call ioa_ ("^a^/", string (s)); end; /* END if print_search_stat_sw */ format_val: proc (v_in, v_out); dcl v_in fixed bin (70) parameter; dcl v_out char (20) parameter; dcl v_out_len fixed bin (21); call ioa_$rsnnl ("^d", v_out, v_out_len, v_in); end format_val; format_vcpu: proc (in_vcpu, out_vcpu); dcl in_vcpu float bin (63) parameter; dcl out_vcpu char (20) parameter; dcl out_vcpu_len fixed bin (21); dcl temp char (12); call ioa_$rsnnl ("^12.5f", temp, out_vcpu_len, in_vcpu); out_vcpu = ltrim (temp); end format_vcpu; end print_the_meters; %page; /* * * * * * * * * * * * * * * * format_time * * * * * * * * * * * * * */ format_time: proc (in_time, out_time); dcl in_time fixed bin (71) parameter; dcl out_time char (20) parameter; zone = ""; call decode_clock_value_$date_time (in_time, month, dom, year, hour, minute, second, micro_sec, dow, zone, code); if code ^= 0 then call error (code, "Converting clock"); tm.hr = hour; tm.min = minute; tm.sec = second; tm.micro = micro_sec; out_time = string (tm); end format_time; %page; /* * * * * * * * * * * * * * reset * * * * * * * * * * * * * * */ reset: proc; meter_starting_time = clock; if ^reset_arg.all_sw & ^reset_arg.desc_sw then call error (error_table_$noarg, "^/No relation or cursor specified to be reset."); if ^reset_arg.desc_sw then reset_arg.all_sw = "1"b; if reset_arg.all_sw then do; if reset_arg.desc_sw then call error (error_table_$bad_arg, "^/ The -all and -path control arguments cannot be used together."); if meter_info.num_rels < 1 then /* Nothing to reset */ call ioa_ ("^/There are no meters to reset."); else do r = 1 to meter_info.num_rels; do c = 1 to meter_info.rel_info (r).number_meters; call reset_the_meter (meter_info.rel_info (r).meter_ptrs (c)); end; end; /* END do r = 1 to meter_info.num_rels */ end; /* if reset_arg.all_sw then do */ else do; /* Specific relation */ reset_one = "0"b; x = 1; do while (x ^= 0 & x <= meter_info.num_rels); if reset_arg.desc_sw then x = locate_uid_in_rel_list (reset_arg.path_desc.uid, x); if x ^= 0 then do; do c = 1 to meter_info.rel_info (x).number_meters; call reset_the_meter (meter_info.rel_info (x).meter_ptrs (c)); end; x = x + 1; end; end; /* END do while (x ^= 0 ) */ if ^reset_one then call ioa_ ("^/Specified meter to be reset does not exists.^/"); end; /* END else do */ end reset; %page; reset_the_meter: proc (I_meter_ptr); dcl I_meter_ptr ptr parameter; vrm_meter_ptr = I_meter_ptr; vrm_meter.meter_start_time = meter_starting_time; vrm_meter.last_call_stats = 0; vrm_meter.total_stats = 0; reset_one = "1"b; end reset_the_meter; %page; delete: proc; if ^delete_arg.all_sw & ^delete_arg.desc_sw then call error (error_table_$noarg, "^/No relation or cursor specified to be deleted."); if delete_arg.all_sw then do; if delete_arg.desc_sw then call error (error_table_$bad_arg, "^/ The -all and -path control arguments cannot be used together."); if meter_info.num_rels < 1 then /* Nothing to delete */ call ioa_ ("^/There are no meters to delete."); else do r = 1 to meter_info.num_rels; call delete_rel_list_ent (r); end; /* END do r = 1 to meter_info.num_rels */ end; /* if delete_arg.all_sw then do */ else do; /* Specific relation */ deleted_one = "0"b; if delete_arg.desc_sw then do; x = locate_uid_in_rel_list (delete_arg.path_desc.uid, 1); if x ^= 0 then do; call delete_rel_list_ent (x); deleted_one = "1"b; end; /* if x ^= 0 then do; */ end; /* END if delete_arg.desc_sw then do; */ else do i = 1 to meter_info.num_rels; call delete_the_meter (i); end; /* END do i = 1 to rel_list */ if ^deleted_one then call ioa_ ("Specified meter to be deleted does not exists.^/"); end; /* END else do */ end delete; %page; delete_the_meter: proc (I_dx); dcl I_dx fixed bin parameter; dcl di fixed bin; dx = I_dx; do di = 1 to meter_info.rel_info (dx).number_meters; meter_ptr = meter_info.rel_info (dx).meter_ptrs (di); if vrm_meter.cursor_ptr ^= null then do; vrm_cursor_ptr = vrm_meter.cursor_ptr; vrm_cursor.switches.meter_sw = "0"b; vrm_cursor.meter_ptr = null; end; free vrm_meter in (meter_info.work_area); deleted_one = "1"b; end; end delete_the_meter; %page; /* * * * * * * * * * * * * * locate_uid_in_rel_list * * * * * * * * */ locate_uid_in_rel_list: proc (search_uid, start_index) returns (fixed bin); dcl start_index fixed bin parameter; /* place to start i rel_list table */ dcl return_value fixed bin; dcl s fixed bin; dcl sx fixed bin; dcl search_uid bit (36) aligned parameter; return_value = 0; if start_index = 0 then sx = 1; else sx = start_index; do s = sx to meter_info.num_rels while (return_value = 0); if meter_info.rel_info (s).uid = search_uid then return_value = s; end; return (return_value); end locate_uid_in_rel_list; %page; /* * * * * * * * * * * * * * * * * * * * error * * * * * * * * * * */ error: proc (cd, err_msg); dcl cd fixed bin (35) parameter; dcl com_err_ entry () options (variable); dcl err_msg char (*) parameter; call com_err_ (cd, PROC_NAME, err_msg); goto exit; end error; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ sub_error: proc (err_cd); dcl err_cd fixed bin (35); O_code = err_cd; end sub_error; %page; /* * * * * * * * * * * * * * * get_path_desc * * * * * * * * * * * * */ get_path_desc: proc (in_path, gpd_arg_ptr); dcl in_path char (*) parameter; dcl gpd_arg_ptr ptr parameter; std_arg_ptr = gpd_arg_ptr; call expand_pathname_ (in_path, std_arg.path_desc.dir, std_arg.path_desc.ent, code); if code ^= 0 then call error (code, in_path); call hcs_$status_long (std_arg.path_desc.dir, std_arg.path_desc.ent, 1, addr (sb), null, code); if code ^= 0 then call error (code, rtrim (std_arg.path_desc.dir) || ">" || std_arg.path_desc.ent); if sb.short.type = Link then call error (error_table_$link, in_path); else if sb.short.type = Directory then do; if sb.long.bit_count = 0 then call error (error_table_$dirseg, in_path); end; std_arg.path_desc.uid = sb.long.uid; end get_path_desc; %page; get_arg: proc (arg_num); dcl arg_num fixed bin parameter; call cu_$arg_ptr (arg_num, arg_ptr, arg_len, code); if code ^= 0 then call error (code, "Getting arg number " || ltrim (char (n))); end get_arg; %page; %include vrm_meter_man; %page; %include vrm_meter; %page; %include status_structures; %page; %include vrm_cursor; %page; %include vrm_open_info; %page; %include vrm_collection_info; %page; %include vrm_rel_desc; %page; dcl 1 sb like status_branch; dcl 1 s, 2 indent char (4) unal, 2 h char (27) unal, 2 s1 char (20) unal, 2 pad2 char (2) unal, 2 s2 char (20) unal; dcl std_arg_ptr ptr; dcl 1 std_arg aligned based (std_arg_ptr), 2 all_sw bit (1) unal, 2 desc_sw bit (1) unal, 2 pad bit (34) unal, 2 relation_name char (32) unal, 2 path_desc unal, 3 dir char (168), 3 ent char (32), 3 uid bit (36) aligned; dcl 1 meter_arg aligned like std_arg; dcl 1 list_arg aligned like std_arg; dcl 1 print_arg aligned like std_arg; dcl 1 delete_arg aligned like std_arg; dcl 1 reset_arg aligned like std_arg; dcl 1 tm, 2 hr pic "z9" unal, 2 colon char (1) init (":") unal, 2 min pic "99" unal, 2 blak char (2) init (" ") unal, 2 sec pic "z9" unal, 2 dot char (1) init ("."), 2 micro pic "999999" unal; %page; dcl addr builtin; dcl all_rel_arg bit (1); dcl all_rel_sw bit (1); dcl arg char (arg_len) based (arg_ptr); dcl arg_len fixed bin (21); dcl arg_ptr ptr; dcl arg_used bit (1); dcl c fixed bin; dcl char builtin; dcl clock builtin; dcl code fixed bin (35); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl data char (70) varying; dcl deleted_one bit (1); dcl delete_args_done bit (1); dcl delete_sw bit (1); dcl dom fixed bin; dcl dow fixed bin; dcl dx fixed bin; dcl empty builtin; dcl error_table_$bad_arg fixed bin (35) ext static; dcl error_table_$bad_subr_arg fixed bin (35) ext static; dcl error_table_$dirseg fixed bin (35) ext static; dcl error_table_$link fixed bin (35) ext static; dcl error_table_$noarg fixed bin (35) ext static; dcl error_table_$too_many_names fixed bin (35) ext static; dcl error_table_$wrong_no_of_args fixed bin (35) ext static; dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl fixed builtin; dcl get_shortest_path_ entry (char (*)) returns (char (168)); dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl hcs_$status_long entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35)); dcl hour fixed bin; dcl i fixed bin; dcl ioa_ entry () options (variable); dcl ioa_$rsnnl entry () options (variable); dcl l fixed bin; dcl last char (20) unal based (addr (s.s1)); dcl last_print_path char (168); dcl lc bit (1); dcl listed_one bit (1); dcl list_args_done bit (1); dcl list_path char (168); dcl list_sw bit (1); dcl ltrim builtin; dcl meter_args_done bit (1); dcl meter_on_sw bit (1) aligned; dcl meter_starting_time fixed bin (71); dcl meter_sw bit (1); dcl micro_sec fixed bin (71); dcl minute fixed bin; dcl month fixed bin; dcl mx fixed bin; dcl n fixed bin; dcl nargs fixed bin; dcl null builtin; dcl on_arg bit (1); dcl printed_one bit (1); dcl print_args_done bit (1); dcl print_last_call_arg_sw bit (1); dcl print_last_call_sw bit (1); dcl print_long_sw bit (1); dcl print_path char (168); dcl print_search_stat_arg_sw bit (1); dcl print_search_stat_sw bit (1); dcl print_sw bit (1); dcl print_total_arg_sw bit (1); dcl print_total_sw bit (1); dcl PROC_NAME char (12) int static options (constant) init ("vrm_meter"); dcl r fixed bin; dcl rel builtin; dcl reset_all_sw bit (1); dcl reset_args_done bit (1); dcl reset_one bit (1); dcl reset_sw bit (1); dcl rtrim builtin; dcl rx fixed bin; dcl saved_meter_seg_ptr ptr int static init (null ()); dcl second fixed bin; dcl string builtin; dcl substr builtin; dcl sys_info$max_seg_size fixed bin (35) ext static; dcl time char (20); dcl tot char (20) unal based (tot_ptr); dcl tot_ptr ptr; dcl tt bit (1); dcl unspec builtin; dcl used_it_sw bit (1); dcl vrm_create_cursor$metering_off entry; dcl vrm_create_cursor$metering_on entry; dcl x fixed bin; dcl year fixed bin; dcl zone char (3); dcl decode_clock_value_$date_time entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin (71), fixed bin, char (3), fixed bin (35)); end vrm_meter;  vrm_modify_by_id.pl1 04/23/85 1414.2rew 04/23/85 1341.9 104058 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ vrm_modify_tuples_by_id: modify_tuples_by_id: proc (I_cursor_ptr, element_id_list_ptr, I_typed_vector_ptr, O_number_of_tuples_modified, O_code); /* . BEGIN_DESCRIPTION Modify the tuples identified in the element_id_list to have the attributes and values specified in the general_typed_vector. The number of tuples modified will be returned. . END_DESCRIPTION */ /* History: 82-09-28 R. Harvey: Initially written. 82-11-16 Roger Lackey : Added new call to metering and locking 83-01-04 Roger Lackey : changed the way that the tuple was copied from the data file to temp space to use the length of the vfile record instead of the max_tuple_length. 83-02-16 Roger Lackey : Added check for zero length record after call to record status. 84-12-19 Thanh Nguyen : Added code to continue on to the next tuple if the tuple was deleted by another parallel process in share mode and stop the premature tuple_not_found. */ %page; /* vrm_modify_tuples_by_id: proc (I_cursor_ptr, element_id_list_ptr, I_typed_vector_ptr, O_number_of_tuples_modified, O_code); */ /* dcl element_id_list_ptr ptr parameter; broken rule due to allocation dependency of vfile_desc_list */ dcl I_typed_vector_ptr ptr parameter; dcl I_cursor_ptr ptr parameter; dcl O_number_of_tuples_modified fixed bin (35) parameter; dcl O_code fixed bin (35) parameter; general_typed_vector_ptr = I_typed_vector_ptr; vrm_cursor_ptr = I_cursor_ptr; O_number_of_tuples_modified = 0; /* true so far */ file_locked = "0"b; on cleanup call tidy_up; if element_id_list.version ^= ELEMENT_ID_LIST_VERSION_1 then call error (error_table_$unimplemented_version); call init_modify; do i = 1 to element_id_list.number_of_elements; tid_ptr = addr (element_id_list.id (i)); vfd_ptr = addr (vfile_desc); vfile_desc = 0; vfd.comp_number = tid.comp_num; vfd.comp_offset = tid.offset; call modify_one_tuple (element_id_list.id (i), vfile_desc, general_typed_vector_ptr); O_number_of_tuples_modified = i; end; O_code = 0; Exit: call tidy_up; return; %page; init_modify: proc; if vrm_cursor.switches.meter_sw then do; call cpu_time_and_paging_ (pf_1, t1, pf_dummy); vrm_meter_ptr = vrm_cursor.meter_ptr; vrm_meter.last_call_stats = 0; end; if general_typed_vector.type ^= GENERAL_TYPED_VECTOR_TYPE then call error (error_table_$unimplemented_version); vrm_open_info_ptr = vrm_cursor.open_info_ptr; vrm_cursor.switches.shared = vrm_cursor.open_info_ptr -> vrm_open_info.switches.shared; vrm_rel_desc_ptr = vrm_cursor.vrm_relation_desc_ptr; vrm_com_ptr = vrm_open_info.com_ptr; if vrm_com.mod_seg_ptr = null () then do; call get_temp_segment_ ("vrm_modify", vrm_com.mod_seg_ptr, code); if code ^= 0 then call error (code); end; temp_seg_ptr = vrm_com.mod_seg_ptr; add_key_list_ptr = temp_seg_ptr; add_key_list_ptr -> key_list.number_of_keys = vrm_rel_desc.number_sec_indexes; i = currentsize (add_key_list_ptr -> key_list); delete_key_list_ptr = addrel (add_key_list_ptr, i); delete_key_list_ptr -> key_list.number_of_keys = vrm_rel_desc.number_sec_indexes; change_bits_ptr = addrel (delete_key_list_ptr, i); change_bits.number_of_change_bits = vrm_rel_desc.number_attrs; i = currentsize (change_bits); tuple_ptr = addrel (change_bits_ptr, i + mod (i, 2)); string (change_bits.position) = "0"b; /* Now insure that the primary key is not being modified (and set up change bits as well) */ vrm_collection_info_ptr = vrm_open_info.primary_key_info_ptr; do i = 1 to general_typed_vector.number_of_dimensions; attr_no = general_typed_vector.dimension (i).identifier; do z = 1 to vrm_collection_info.number_of_attributes; if attr_no = vrm_collection_info.attribute (z).attr_index then call error (mdbm_error_$mod_key_attr); end; change_bits.position (attr_no) = "1"b; end; string (rs_info.flags) = "0"b; /* Clear flags */ rs_info.locate_sw = "1"b; /* set for search by descriptor */ end init_modify; %page; modify_one_tuple: proc (element_id, vfile_descriptor, general_typed_vector_ptr); /* Parameters */ dcl element_id bit (36) aligned parameter; dcl vfile_descriptor fixed bin (35) parameter; dcl general_typed_vector_ptr ptr parameter; rs_info.descriptor = vfile_descriptor; /* This is record to locate */ if vrm_cursor.switches.shared then do; if vrm_cursor.opening_mode = KSQU then call lock; end; call iox_$control (vrm_cursor.iocb_ptr, "record_status", addr (rs_info), code); if code ^= 0 then call error (error_table_$no_record); else if vrm_cursor.switches.shared then if rs_info.record_length = 0 | rs_info.block_ptr -> block_head.is_this_block_free then go to exit_of_modify_one_tuple; tuple_ptr -> tuple_templet = rs_info.record_ptr -> tuple_templet; /* Copy tuple to workspace */ if vrm_rel_desc.switches.indexed then do; call vrmu_build_index_list (vrm_rel_desc_ptr, vrm_open_info_ptr, tuple_ptr, change_bits_ptr, delete_key_list_ptr, code); if code ^= 0 then call error (code); end; call vrmu_cv_vector_to_tuple (vrm_rel_desc_ptr, tuple_ptr, general_typed_vector_ptr, "1"b /* MODIFY */, tuple_length, code); if code ^= 0 then call error (code); if vrm_rel_desc.switches.indexed then do; call vrmu_build_index_list (vrm_rel_desc_ptr, vrm_open_info_ptr, tuple_ptr, change_bits_ptr, add_key_list_ptr, code); if code ^= 0 then call error (code); end; if vrm_rel_desc.switches.indexed then do; call vrmu_delete_indexes (vrm_cursor.iocb_ptr, delete_key_list_ptr, element_id, code); if code ^= 0 then call error (code); end; call iox_$rewrite_record (vrm_cursor.iocb_ptr, tuple_ptr, tuple_length, code); if code ^= 0 then call error (code); if vrm_rel_desc.switches.indexed then do; call vrmu_add_indexes (vrm_cursor.iocb_ptr, add_key_list_ptr, element_id, code); if code ^= 0 then call error (code); end; exit_of_modify_one_tuple: if vrm_cursor.switches.shared then call unlock; if vrm_cursor.switches.meter_sw then vrm_meter.last_call_stats.number_tuples_modified = vrm_meter.last_call_stats.number_tuples_modified + 1; end modify_one_tuple; %page; error: proc (ecode); dcl ecode fixed bin (35); if ecode = error_table_$no_record then O_code = dm_error_$no_tuple_id; else O_code = ecode; go to Exit; end error; /* * * * * * * * * * * * * * * * * * * tidy_up * * * * * * * * * * * */ tidy_up: proc; if file_locked then call iox_$control (iocb_ptr, "set_file_lock", addr (UNLOCK), code); if vrm_cursor.switches.meter_sw then do; call cpu_time_and_paging_ (pf_2, t2, pf_dummy); vrm_meter.last_call_stats.last_time_of_stats = clock; t3 = t2 - t1; vrm_meter.last_call_stats.vcpu_time = divide (t3, 1000000, 63); vrm_meter.last_call_stats.page_faults = pf_2 - pf_1; vrm_meter.last_call_stats.number_times_used = 1; vrm_meter.total_stats.last_time_of_stats = 0; vrm_meter.total_stats = vrm_meter.total_stats + vrm_meter.last_call_stats; end; end tidy_up; %page; /* * * * * * * * * * * * * * lock * * * * * * * * * * * * * * * * */ lock: proc; call iox_$control (iocb_ptr, "set_file_lock", addr (LOCK), code); if code ^= 0 then call error (code); file_locked = "1"b; if vrm_cursor.switches.meter_sw then vrm_meter.last_call_stats.number_times_locked = vrm_meter.last_call_stats.number_times_locked + 1; end lock; /* * * * * * * * * * * * * * unlock * * * * * * * * * * * * * * * * */ unlock: proc; if file_locked then do; call iox_$control (iocb_ptr, "set_file_lock", addr (UNLOCK), code); if code ^= 0 then call error (code); end; file_locked = "0"b; end unlock; %page; %include dm_typed_vector_list; %page; %include vu_typed_vector; %page; %include vrm_cursor; %page; %include vrm_tuple; %page; %include vrm_open_info; %page; %include vrm_collection_info; %page; %include vrm_rel_desc; %page; %include vrm_change_bits; %page; %include vrm_key_list; %page; %include vrm_com; %page; %include dm_element_id_list; %page; %include mdbm_rs_info; %page; %include vrm_meter; %page; dcl 1 tid aligned based (tid_ptr), /* MRDS tuple id (tid) */ 2 non_std_desc bit (1) unal, /* Non-standard descriptor bit */ 2 temp bit (1) unal, /* On if temp relation */ 2 file_id bit (7) unal, /* File id from mrds db_model file_id_list */ 2 comp_num bit (10) unal, /* Component number */ 2 offset bit (17) unal; /* Offset within component */ dcl tid_ptr pointer; dcl 1 vfd aligned based (vfd_ptr), /* Vfile desc */ 2 pad_1 bit (8) unal, 2 comp_number bit (10) unal, /* Component number */ 2 comp_offset bit (17) unal, /* Offset with in component */ 2 pade_2 bit (1) unal; dcl vfd_ptr pointer; /* Pointer to vfd structure */ dcl 1 block_head based, /* block header of vfile */ 2 is_preceding_block_free bit (1) unal, 2 is_this_block_free bit (1) unal, 2 block_size fixed (19) unal, 2 flags, 3 lock_flag bit (1) unal, 3 stationary bit (1) unal, 3 indirect bit (1) unal, 3 after_applies bit (1) unal, 3 pad bit (6) unal, 3 excess_words fixed (3) unal, /* only used in indirect allocations */ 2 prev_free_block fixed (18) aligned, 2 next_free_block fixed (18) aligned; %page; dcl add_key_list_ptr ptr; dcl attr_no fixed bin (17); dcl cleanup condition; dcl clock builtin; dcl code fixed bin (35); dcl cpu_time_and_paging_ entry (fixed bin, fixed bin (71), fixed bin); dcl delete_key_list_ptr ptr; dcl divide builtin; dcl file_locked bit (1); dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl i fixed bin (35); dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl iox_$rewrite_record entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl KSQU fixed bin int static options (constant) init (10); dcl LOCK bit (2) aligned int static options (constant) init ("10"b); dcl pf_1 fixed bin; dcl pf_2 fixed bin; dcl pf_dummy fixed bin; dcl t1 fixed bin (71); dcl t2 fixed bin (71); dcl t3 float bin (63); dcl temp_seg_ptr ptr; dcl tuple_templet char (rs_info.record_length) based; dcl UNLOCK bit (2) aligned int static options (constant) init ("00"b); dcl vrmu_add_indexes entry (ptr, ptr, bit (36) aligned, fixed bin (35)); dcl vrmu_build_index_list entry (ptr, ptr, ptr, ptr, ptr, fixed bin (35)); dcl vrmu_cv_vector_to_tuple entry (ptr, ptr, ptr, bit (1) aligned, fixed bin (21), fixed bin (35)); dcl vrmu_delete_indexes entry (ptr, ptr, bit (36) aligned, fixed bin (35)); dcl vfile_desc fixed bin (35) aligned; dcl z fixed bin; dcl ( dm_error_$no_tuple_id, error_table_$unimplemented_version, error_table_$no_record, mdbm_error_$mod_key_attr, sys_info$max_seg_size ) fixed bin (35) ext static; dcl (addrel, addr, currentsize, fixed, mod, null, rel, string) builtin; end vrm_modify_tuples_by_id;  vrm_open.pl1 04/10/85 0857.2r w 04/08/85 1128.6 36153 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ vrm_open: open: proc (I_rel_dir, I_rel_name, O_opening_id, O_code); /* . BEGIN_DESCRIPTION * * * Open the specified relation. This requires extracting * relation header information into an opening info structure and * setting a relation opening identifier for this opening. * * . END_DESCRIPTION */ /* History * * 82-08-19 R. Harvey: Initially written * * 83-10-24 Roger Lackey : for better performance changed call to hcs_$status_long to hcs_$get_uid_file to get uid. */ %page; /* Parameters */ dcl I_rel_dir char (*); dcl I_rel_name char (*); dcl O_opening_id bit (36) aligned; dcl O_code fixed bin (35); O_opening_id = "0"b; vrm_open_info_ptr = null (); new_opening = "0"b; rel_name = rtrim (I_rel_name); rel_model_name = rtrim (rel_name) || ".m"; call initiate_file_ (I_rel_dir, rel_model_name, R_ACCESS, fm_ptr, (0), (0)); if fm_ptr ^= null () then do; /* MRDS permanent relation */ call initiate_file_ (I_rel_dir, "db_model", R_ACCESS, dbm_ptr, (0), (0)); if dbm_ptr = null then call error (error_table_$noentry); end; else ; /* 'model' info is in the relation */ call hcs_$get_uid_file (I_rel_dir, rel_name, file_uid, code); /* Try for uid of relation */ if code ^= 0 then if code ^= error_table_$no_s_permission then call error (code); /* This works even without s_permission */ call vrm_open_man$get_opening_id (file_uid, O_opening_id, vrm_com_ptr, vrm_open_info_ptr, code); /* Get an opening id */ if code ^= 0 then call error (code); if vrm_open_info_ptr = null () then do; /* Not already open */ new_opening = "1"b; call vrmu_init_rel_desc (I_rel_dir, rel_name, file_uid, fm_ptr, vrm_com_ptr, O_opening_id, vrm_open_info_ptr, code); if code ^= 0 then call error (code); call vrm_open_man$set_open_info_ptr (O_opening_id, vrm_open_info_ptr); end; /* not already open */ else vrm_open_info.number_of_openings = vrm_open_info.number_of_openings + 1; O_code = 0; Exit: return; %page; error: proc (error_code); if new_opening then do; call vrm_open_man$remove_opening (O_opening_id); if vrm_open_info_ptr ^= null () then do; wa_ptr = vrm_open_info.com_ptr -> vrm_com.work_area_ptr; free vrm_open_info in (wa); end; end; O_opening_id = "0"b; O_code = error_code; go to Exit; dcl error_code fixed bin (35); end; %page; %include vrm_com; %page; %include vrm_open_info; %page; %include vrm_rel_desc; %page; %include vrm_collection_info; %page; %include access_mode_values; %page; dcl hcs_$get_uid_file entry (char (*), char (*), bit (36) aligned, fixed bin (35)); dcl initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35)); dcl vrmu_init_rel_desc entry (char (*), char (*), bit (36) aligned, ptr, ptr, bit (36) aligned, ptr, fixed bin (35)); dcl vrm_open_man$get_opening_id entry (bit (36) aligned, bit (36) aligned, ptr, ptr, fixed bin (35)); dcl vrm_open_man$set_open_info_ptr entry (bit (36) aligned, ptr); dcl vrm_open_man$remove_opening entry (bit (36) aligned); dcl error_table_$noentry fixed bin (35) ext static; dcl error_table_$no_s_permission fixed bin (35) ext static; dcl sys_info$max_seg_size fixed bin (35) ext static; dcl code fixed bin (35); dcl dbm_ptr ptr; dcl file_uid bit (36) aligned; dcl fm_ptr ptr; dcl new_opening bit (1) aligned; dcl rel_name char (30); dcl rel_model_name char (32); dcl wa_ptr ptr; dcl wa area based (wa_ptr); dcl (addr, fixed, null, rel, rtrim) builtin; end vrm_open;  vrm_open_man.pl1 11/23/84 0800.9r w 11/21/84 0933.9 97497 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ vrm_open_man: proc; return; /* . BEGIN_DESCRIPTION This module contains the entry points necessary for managing the opening and closing of relations by the vfile_relation_manager. . END_DESCRIPTION */ /* History 82-08-17 R. Harvey: Initially written 82-10-15 R. Harvey: Rewritten to manage opening_ids as one per relation, and also to pass back error codes 82-11-02 R. Harvey: Modified to use vrm_open_info structure 82-12-14 Roger Lackey : Added call to destroy_all_iocbs_for_oid when removing an opening. */ %page; get_opening_id: entry (I_uid, O_opening_id, O_com_ptr, O_open_info_ptr, O_code); /* Add a new opening to the opening table. If the table does not exist a temporary segment is created and initialized. */ /* Parameters */ dcl I_uid bit (36) aligned parameter; dcl O_opening_id bit (36) aligned parameter; dcl O_com_ptr ptr parameter; /* dcl O_open_info_ptr ptr parameter; */ dcl O_code fixed bin (35) parameter; if INTERNAL_VRM_COM_PTR = null () /* If first call... */ then call create_com_segment; /* ... make vrm_com_ptr point to something */ else vrm_com_ptr = INTERNAL_VRM_COM_PTR; /* First, see if this relation is already open */ call search_for_uid (I_uid, opening_id); if opening_id = "0"b then do; /* Nope */ if vrm_com.next_free_oid = "0"b then call create_and_link_oid_section; opening_id = addr (vrm_com.next_free_oid) -> oid_template.right_half; call unlink (opening_id, addr (vrm_com.next_free_oid)); oid_entry_ptr = ptr (vrm_com_ptr, opening_id); oid_entry.uid = I_uid; oid_entry.open_info_ptr = null (); call link (opening_id, addr (vrm_com.first_assigned_oid)); end; else oid_entry_ptr = ptr (vrm_com_ptr, opening_id); addr (O_opening_id) -> oid_template.left_half = "0"b; addr (O_opening_id) -> oid_template.right_half = opening_id; O_com_ptr = vrm_com_ptr; O_open_info_ptr = oid_entry.open_info_ptr; O_code = 0; Exit: return; %page; set_open_info_ptr: entry (I_opening_id, I_open_info_ptr); /* Given an opening_id set the associated open_info_ptr. */ /* Parameters */ dcl I_opening_id bit (36) aligned; dcl I_open_info_ptr ptr; vrm_com_ptr = INTERNAL_VRM_COM_PTR; oid_entry_ptr = ptr (vrm_com_ptr, addr (I_opening_id) -> oid_template.right_half); oid_entry.open_info_ptr = I_open_info_ptr; return; %page; get_open_info_ptr: entry (I_opening_id, O_open_info_ptr, O_code); /* Given an opening_id return the associated open_info_ptr. */ /* Parameters */ /* dcl I_opening_id bit (36) aligned parameter; */ dcl O_open_info_ptr ptr parameter; /* dcl O_code fixed bin (35) parameter; */ if INTERNAL_VRM_COM_PTR = null then call error (dm_error_$no_opening); vrm_com_ptr = INTERNAL_VRM_COM_PTR; if I_opening_id > vrm_com.highest_oid then call error (dm_error_$no_opening); oid_entry_ptr = ptr (vrm_com_ptr, addr (I_opening_id) -> oid_template.right_half); if fixed (oid_entry.next_oid) > fixed (vrm_com.highest_oid) | fixed (oid_entry.prev_oid) > fixed (vrm_com.highest_oid) | oid_entry.uid = "0"b | oid_entry.open_info_ptr = null () then call error (dm_error_$no_opening); if oid_entry.open_info_ptr -> vrm_open_info.opening_id ^= I_opening_id then call error (dm_error_$no_opening); O_open_info_ptr = oid_entry.open_info_ptr; O_code = 0; return; %page; remove_opening: entry (I_opening_id); /* Given an opening_id, remove it from the opening table. */ /* Parameters */ /* dcl I_opening_id bit (36) aligned; */ vrm_com_ptr = INTERNAL_VRM_COM_PTR; opening_id = addr (I_opening_id) -> oid_template.right_half; oid_entry_ptr = ptr (vrm_com_ptr, opening_id); oid_entry.uid = "0"b; oid_entry.open_info_ptr = null (); /* Invalidate entry */ call unlink (opening_id, addr (vrm_com.first_assigned_oid)); call link (opening_id, addr (vrm_com.next_free_oid)); I_opening_id = "0"b; /* Let him not use it again */ return; %page; get_open_relations: entry (I_user_area_ptr, O_relation_list_ptr, O_code); dcl I_user_area_ptr ptr parameter; dcl O_relation_list_ptr ptr parameter; /* dcl O_code fixed bin (35) parameter; */ if INTERNAL_VRM_COM_PTR = null then call error (dm_error_$no_opening); vrm_com_ptr = INTERNAL_VRM_COM_PTR; vrl_number_of_openings = 0; oid = vrm_com.first_assigned_oid; do while (oid ^= "0"b); oid_entry_ptr = ptr (vrm_com_ptr, addr (oid) -> oid_template.right_half); vrl_number_of_openings = vrl_number_of_openings + 1; addr (oid) -> oid_template.right_half = oid_entry.next_oid; end; allocate vrm_relation_list in (user_area) set (vrm_relation_list_ptr); i = 0; oid = vrm_com.first_assigned_oid; do while (oid ^= "0"b); oid_entry_ptr = ptr (vrm_com_ptr, addr (oid) -> oid_template.right_half); i = i + 1; vrm_relation_list.opening (i).opening_id = oid; vrm_relation_list.opening (i).open_info_ptr = oid_entry.open_info_ptr; addr (oid) -> oid_template.right_half = oid_entry.next_oid; end; O_relation_list_ptr = vrm_relation_list_ptr; O_code = 0; return; %page; create_com_segment: proc; dcl code fixed bin (35); /* get a temporary segment from the process dir */ call get_temp_segment_ ("vrm_open_man", INTERNAL_VRM_COM_PTR, code); if code ^= 0 then call error (code); vrm_com_ptr = INTERNAL_VRM_COM_PTR; /* initialize the temp segment */ vrm_com.highest_oid = "0"b; vrm_com.next_free_oid = "0"b; vrm_com.first_assigned_oid = "0"b; vrm_com.get_seg_ptr, vrm_com.put_seg_ptr, vrm_com.mod_seg_ptr = null (); vrm_com.work_area_ptr = addr (vrm_com.oid_area); vrm_com.oid_area = empty (); return; end; %page; create_and_link_oid_section: proc; /* This procedure will allocate a new oid_table section in the temp area. It will be initialized and linked into the appropriate place. */ dcl entry_size fixed bin; dcl i fixed bin; /* dcl new_oid_section_ptr ptr; */ dcl prev_oid bit (18) unal; allocate new_oid_section in (vrm_com.oid_area) set (new_oid_section_ptr); /* init new section */ oid_entry_ptr = new_oid_section_ptr; entry_size = size (oid_entry); prev_oid = "0"b; do i = 1 to vrm_data_$oid_slots_per_section; oid_entry.uid = "0"b; oid_entry.open_info_ptr = null (); oid_entry.next_oid = rel (addrel (oid_entry_ptr, entry_size)); oid_entry.prev_oid = prev_oid; oid_entry.valid = "0"b; prev_oid = rel (oid_entry_ptr); oid_entry_ptr = addrel (oid_entry_ptr, entry_size); end; ptr (oid_entry_ptr, prev_oid) -> oid_entry.next_oid = "0"b; /* readjust the last entry */ if vrm_com.highest_oid < "000000000000000000"b || prev_oid then addr (vrm_com.highest_oid) -> oid_template.right_half = prev_oid; addr (vrm_com.next_free_oid) -> oid_template.right_half = rel (new_oid_section_ptr); return; end; %page; link: proc (opening_id, place_to_link); dcl opening_id bit (18) unal parameter; dcl place_to_link ptr parameter; dcl temp_hold bit (18) unal; quit_signaled = "0"b; on quit quit_signaled = "1"b; temp_hold = place_to_link -> oid_template.right_half; place_to_link -> oid_template.right_half = opening_id; if temp_hold ^= "0"b then ptr (vrm_com_ptr, temp_hold) -> oid_entry.prev_oid = opening_id; oid_entry_ptr = ptr (vrm_com_ptr, opening_id); oid_entry.prev_oid = "0"b; oid_entry.next_oid = temp_hold; revert quit; if quit_signaled then do; quit_signaled = "0"b; signal quit; end; end link; %page; unlink: proc (oid_to_be_unlinked, place_to_unlink); dcl oid_to_be_unlinked bit (18) unal parameter; dcl place_to_unlink ptr parameter; dcl walk_oid bit (18) unal; dcl found bit (1) unaligned; quit_signaled = "0"b; on quit quit_signaled = "1"b; walk_oid = place_to_unlink -> oid_template.right_half; found = "0"b; do while (walk_oid ^= "0"b & ^found); oid_entry_ptr = ptr (vrm_com_ptr, walk_oid); if walk_oid = oid_to_be_unlinked then do; found = "1"b; if oid_entry.prev_oid ^= "0"b then ptr (vrm_com_ptr, oid_entry.prev_oid) -> oid_entry.next_oid = oid_entry.next_oid; else place_to_unlink -> oid_template.right_half = oid_entry.next_oid; if oid_entry.next_oid ^= "0"b then ptr (vrm_com_ptr, oid_entry.next_oid) -> oid_entry.prev_oid = oid_entry.prev_oid; end; walk_oid = oid_entry.next_oid; /* go to next entry */ end; revert quit; if quit_signaled then do; quit_signaled = "0"b; signal quit; end; end unlink; %page; search_for_uid: proc (uid, oid); dcl uid bit (36) aligned parameter; dcl oid bit (18) unal parameter; dcl found bit (1) aligned; oid = addr (vrm_com.first_assigned_oid) -> oid_template.right_half; found = "0"b; do while (^found & oid ^= "0"b); oid_entry_ptr = ptr (vrm_com_ptr, oid); if oid_entry.uid = uid then found = "1"b; else oid = oid_entry.next_oid; end; end search_for_uid; %page; error: proc (ecode); dcl ecode fixed bin (35) parameter; O_code = ecode; goto Exit; end error; %page; %include vrm_com; %page; %include vrm_open_info; %page; %include vrm_relation_list; %page; dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl vrm_data_$oid_slots_per_section fixed bin external static; dcl i fixed bin (35); dcl opening_id bit (18) unal; dcl oid bit (36) aligned; dcl oid_entry_ptr ptr; dcl quit_signaled bit (1) unal; dcl 1 new_oid_section (vrm_data_$oid_slots_per_section) based (new_oid_section_ptr), 2 new_oid_entry like oid_entry; dcl 1 oid_template aligned based, 2 left_half bit (18) unal, 2 right_half bit (18) unal; dcl 1 oid_entry aligned based (oid_entry_ptr), 2 uid bit (36) aligned, 2 open_info_ptr ptr unal, 2 next_oid bit (18) unal, 2 prev_oid bit (18) unal, 2 valid bit (36) aligned; dcl sys_info$max_seg_size fixed bin (35) ext static; dcl dm_error_$no_opening fixed bin (35) ext static; dcl quit condition; dcl (addr, addrel, empty, fixed, null, ptr, rel, size, substr) builtin; dcl new_oid_section_ptr ptr internal static; dcl INTERNAL_VRM_COM_PTR ptr internal static init (null ()); /* This points the the vrm_com structure FOR THIS PROCESS */ dcl user_area area based (I_user_area_ptr); end vrm_open_man;  vrm_put.pl1 08/15/86 1628.8r 08/15/86 1437.0 113364 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ vrm_put_tuple: put_tuple: proc (I_relation_cursor_ptr, I_typed_vector_ptr, O_element_id, O_code); /* . BEGIN_DESCRIPTION Put a tuple into the relation specified by I_relation_cursor_ptr and update all of the indices for that relation to reflect the presence of the new tuple. . END_DESCRIPTION */ /* History: 82-09-15 R. Harvey: Originally written from mu_store. /****^ HISTORY COMMENTS: 1) change(86-07-17,Dupuis), approve(86-08-07,MCR7491), audit(86-08-07,Gilcrease), install(86-08-15,MR12.0-1127): Changed the calling sequence of vrm_put_tuples to have the correct number of parameters. Changed a loop counter that this entrypoint uses. END HISTORY COMMENTS */ %page; /* vrm_put_tuple: put_tuple: proc (I_relation_cursor_ptr, I_typed_vector_ptr, O_element_id, O_code); */ /* Parameters */ dcl I_relation_cursor_ptr ptr; dcl I_typed_vector_ptr ptr; dcl O_element_id bit (36) aligned; dcl O_code fixed bin (35); simple_typed_vector_ptr, general_typed_vector_ptr = I_typed_vector_ptr; vrm_cursor_ptr = I_relation_cursor_ptr; O_element_id = "0"b; O_code = 0; file_locked = "0"b; on cleanup call tidy_up; if vrm_cursor.switches.meter_sw then do; call cpu_time_and_paging_ (pf_1, t1, pf_dummy); vrm_meter_ptr = vrm_cursor.meter_ptr; vrm_meter.last_call_stats = 0; end; if simple_typed_vector.type = SIMPLE_TYPED_VECTOR_TYPE then simple_vector = "1"b; else simple_vector = "0"b; call init_put; call put_one_tuple (simple_typed_vector_ptr, O_element_id); O_code = 0; Exit: call tidy_up; return; vrm_put_tuples: put_tuples: entry (I_relation_cursor_ptr, I_typed_vector_list_ptr, I_element_id_list_ptr, O_number_put, O_code); /* Parameters */ /* dcl I_relation_cursor_ptr ptr parameter; */ dcl I_typed_vector_list_ptr ptr parameter; dcl I_element_id_list_ptr ptr parameter; dcl O_number_put fixed bin (35) parameter; /* dcl O_code fixed bin (35) parameter; */ O_code, O_number_put = 0; file_locked = "0"b; on cleanup call tidy_up; if vrm_cursor.switches.meter_sw then do; call cpu_time_and_paging_ (pf_1, t1, pf_dummy); vrm_meter_ptr = vrm_cursor.meter_ptr; vrm_meter.last_call_stats = 0; end; typed_vector_list_ptr = I_typed_vector_list_ptr; vrm_cursor_ptr = I_relation_cursor_ptr; if typed_vector_list.version ^= TYPED_VECTOR_LIST_VERSION_1 then call error (error_table_$unimplemented_version); element_id_list_ptr = I_element_id_list_ptr; if element_id_list.version ^= ELEMENT_ID_LIST_VERSION_1 then call error (error_table_$unimplemented_version); call init_put; do vpt_index = 1 to typed_vector_list.number_of_vectors; call put_one_tuple (typed_vector_list.vector_ptr (vpt_index), element_id_list.id (vpt_index)); O_number_put = O_number_put + 1; end; O_code = 0; go to Exit; %page; init_put: proc; vrm_open_info_ptr = vrm_cursor.open_info_ptr; vrm_cursor.switches.shared = vrm_open_info.switches.shared; vrm_rel_desc_ptr = vrm_open_info.relation_model_ptr; vrm_com_ptr = vrm_open_info.com_ptr; if vrm_com.put_seg_ptr = null () then do; call get_temp_segment_ ("vrm_put", vrm_com.put_seg_ptr, code); if code ^= 0 then call error (code); end; /* then do */ temp_seg_ptr = vrm_com.put_seg_ptr; /* Initialize values for structures in the temp seg */ bit_len = 9 * vrm_rel_desc.maximum_data_length; cb_number_of_change_bits = vrm_rel_desc.number_attrs; ksl_number_of_values = vrm_rel_desc.number_primary_key_attrs; key_list_ptr = temp_seg_ptr; key_list.number_of_keys = vrm_rel_desc.number_sec_indexes; i = currentsize (key_list); key_source_list_ptr = addrel (key_list_ptr, i + mod (i, 2)); key_source_list.number_of_values = ksl_number_of_values; i = currentsize (key_source_list); kv_ptr = addrel (key_source_list_ptr, i + mod (i, 2)); i = currentsize (key_vals); change_bits_ptr = addrel (kv_ptr, i + mod (i, 2)); change_bits.number_of_change_bits = cb_number_of_change_bits; i = currentsize (change_bits); tuple_ptr = addrel (change_bits_ptr, i + mod (i, 2)); if cb_number_of_change_bits <= 128 then string (change_bits.position) = substr (all_ones, 1, cb_number_of_change_bits); else string (change_bits.position) = substr (all_ones || all_ones, 1, cb_number_of_change_bits); end init_put; %page; put_one_tuple: proc (I_typed_vector_ptr, O_mrds_id); /* Parameters */ dcl I_typed_vector_ptr ptr parameter; dcl O_mrds_id bit (36) aligned parameter; call vrmu_cv_vector_to_tuple (vrm_rel_desc_ptr, tuple_ptr, I_typed_vector_ptr, "0"b /* NOT mod */, tuple_length, code); if code ^= 0 then call error (code); bd_ptr = addr (tuple.data); do i = 1 to ksl_number_of_values; /* copy out values and build key source list */ vrm_attr_info_ptr = addr (vrm_rel_desc.attr (vrm_open_info.primary_key_info_ptr -> vrm_collection_info.attribute (i).attr_index)); /* to attr info */ key_source_list.val_info.val_ptr (i) = addr (key_vals (i)); /* set source value ptr */ key_source_list.val_info.desc_ptr (i) = addr (vrm_attr_info.descriptor); /* and ptr to descr. */ if vrm_attr_info.varying then do; /* if var. attr. */ offset = tuple.var_offsets (vrm_attr_info.bit_offset); /* bit offset */ key_source_list.val_info.val_ptr (i) = addr (bit_data (offset)); end; /* if varying */ else key_source_list.val_info.val_ptr (i) -> bit_str = substr (data_str, vrm_attr_info.bit_offset, vrm_attr_info.bit_length); end; /* building key source list */ call vrmu_encode_key (key_source_list_ptr, pri_key, (0), code); if code ^= 0 then call error (code); /* Now finish up the header on the primary key */ index_ptr = addrel (addr (pri_key), 1); /* past length word of varying string */ index_value_length = 0; /* save warning flag */ index.rel_id = vrm_rel_desc.rel_id; index.index_id = "0"b; /* Initialize the key list */ if vrm_rel_desc.switches.indexed then do; call vrmu_build_index_list (vrm_rel_desc_ptr, vrm_open_info_ptr, tuple_ptr, change_bits_ptr, key_list_ptr, code); if code ^= 0 then call error (code); end; /* indexed */ if vrm_cursor.switches.shared & vrm_cursor.opening_mode = KSQU then call lock; /* Lock file wile we add tuple */ call vrmu_add_tuple (vrm_rel_desc_ptr, vrm_cursor.iocb_ptr, addr (pri_key), tuple_id, tuple_ptr, tuple_length, tt_ptr, code); if code ^= 0 then call error (code); if vrm_rel_desc.switches.indexed then do; /* add indexes if necess. */ call vrmu_add_indexes (vrm_cursor.iocb_ptr, key_list_ptr, tuple_id, code); if code ^= 0 then call error (code); end; /* adding indexes */ if file_locked then call unlock; O_mrds_id = tuple_id; if vrm_cursor.switches.meter_sw then vrm_meter.last_call_stats.number_tuples_stored = vrm_meter.last_call_stats.number_tuples_stored + 1; end put_one_tuple; %page; error: proc (ecode); dcl ecode fixed bin (35); O_code = ecode; goto Exit; end error; /* * * * * * * * * * * * * * * * * * * tidy_up * * * * * * * * * * * */ tidy_up: proc; if file_locked then call iox_$control (iocb_ptr, "set_file_lock", addr (UNLOCK), code); if vrm_cursor.switches.meter_sw then do; call cpu_time_and_paging_ (pf_2, t2, pf_dummy); vrm_meter.last_call_stats.last_time_of_stats = clock; t3 = t2 - t1; vrm_meter.last_call_stats.vcpu_time = divide (t3, 1000000, 63); vrm_meter.last_call_stats.page_faults = pf_2 - pf_1; vrm_meter.last_call_stats.number_times_used = 1; vrm_meter.total_stats.last_time_of_stats = 0; vrm_meter.total_stats = vrm_meter.total_stats + vrm_meter.last_call_stats; end; end tidy_up; %page; /* * * * * * * * * * * * * * lock * * * * * * * * * * * * * * * * */ lock: proc; call iox_$control (iocb_ptr, "set_file_lock", addr (LOCK), code); if code ^= 0 then call error (code); file_locked = "1"b; if vrm_cursor.switches.meter_sw then vrm_meter.last_call_stats.number_times_locked = vrm_meter.last_call_stats.number_times_locked + 1; end lock; /* * * * * * * * * * * * * * unlock * * * * * * * * * * * * * * * * */ unlock: proc; if file_locked then do; call iox_$control (iocb_ptr, "set_file_lock", addr (UNLOCK), code); if code ^= 0 then call error (code); end; file_locked = "0"b; end unlock; %page; %include vu_typed_vector; %page; %include dm_typed_vector_list; %page; %include dm_element_id_list; %page; %include vrm_open_info; %page; %include vrm_collection_info; %page; %include vrm_rel_desc; %page; %include vrm_com; %page; %include vrm_cursor; %page; %include vrm_tuple; %page; %include vrm_index; %page; %include vrm_key_source_list; %page; %include vrm_key_list; %page; %include vrm_change_bits; %page; %include vrm_meter; %page; dcl 1 rs, /* Record_status_info */ 2 version fixed bin init (2), 2 flags aligned, 3 lock_sw bit (1) unal init ("0"b), 3 unlock_sw bit (1) unal init ("0"b), 3 create_sw bit (1) unal init ("0"b), 3 locate_sw bit (1) unal init ("1"b), /* Only switch on */ 3 inc_ref_count bit (1) unal init ("0"b), 3 dec_ref_count bit (1) unal init ("0"b), 3 locate_pos_sw bit (1) unal init ("0"b), 3 mbz1 bit (29) unal init ("0"b), 2 record_length fixed bin (21) init (0), 2 max_rec_len fixed bin (21) init (0), 2 record_ptr pointer init (null), 2 descriptor fixed bin (35), 2 ref_count fixed bin (34), 2 time_last_modified fixed bin (71), 2 modifier fixed bin (35), 2 block_ptr pointer ptr unal, 2 last_image_modifier fixed bin (35), 2 mbz2 fixed bin init (0); dcl addr builtin; dcl addrel builtin; dcl all_ones bit (128) int static options (constant) init ((128)"1"b); dcl bd_ptr ptr; dcl bit_data (bit_len) bit (1) unal based (bd_ptr); dcl bit_len fixed bin (35); dcl bit_str bit (vrm_attr_info.bit_length) based; dcl cleanup condition; dcl clock builtin; dcl code fixed bin (35); dcl cpu_time_and_paging_ entry (fixed bin, fixed bin (71), fixed bin); dcl currentsize builtin; dcl data_str bit (bit_len) based (bd_ptr); dcl divide builtin; dcl file_locked bit (1); dcl fixed builtin; dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl i fixed bin (17); dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl key_vals (ksl_number_of_values) char (vrm_data_$max_kattr_length) based (kv_ptr); /* to hold values so they are aligned */ dcl KSQU fixed bin int static options (constant) init (10); dcl kv_ptr ptr; /* ptr to key values */ dcl LOCK bit (2) aligned int static options (constant) init ("10"b); dcl mod builtin; dcl null builtin; dcl offset fixed bin (35); /* temp attr offset */ dcl pf_1 fixed bin; dcl pf_2 fixed bin; dcl pf_dummy fixed bin; dcl pri_key char (256) var; /* holds encoded primary key */ dcl rel builtin; dcl simple_vector bit (1) aligned; dcl string builtin; dcl substr builtin; dcl t1 fixed bin (71); dcl t2 fixed bin (71); dcl t3 float bin (63); dcl temp_seg_ptr ptr; dcl tt_ptr ptr; /* pointer to tuple in the vfile */ dcl tuple_id bit (36) aligned; dcl UNLOCK bit (2) aligned int static options (constant) init ("00"b); dcl vpt_index fixed bin (24); dcl vrmu_add_indexes entry (ptr, ptr, bit (36) aligned, fixed bin (35)); dcl vrmu_add_tuple entry (ptr, ptr, ptr, bit (36) aligned, ptr, fixed bin (21), ptr, fixed bin (35)); dcl vrmu_build_index_list entry (ptr, ptr, ptr, ptr, ptr, fixed bin (35)); dcl vrmu_cv_vector_to_tuple entry (ptr, ptr, ptr, bit (1) aligned, fixed bin (21), fixed bin (35)); dcl vrmu_encode_key entry (ptr, char (256) varying, fixed bin (35), fixed bin (35)); dcl error_table_$unimplemented_version ext fixed bin (35); dcl (vrm_data_$max_kattr_length, sys_info$max_seg_size) ext fixed bin (35); end vrm_put_tuple;  vrm_set_scope.pl1 11/23/84 0800.9r w 11/21/84 0933.9 15840 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ vrm_set_scope: set_scope: proc (I_rel_opening_id, I_this_process_permission, I_other_process_permission, O_code); /* . BEGIN_DESCRIPTION Take the scope setting requested by MRDS for the use of the page_file manager and convert it into a vfile_ opening mode. 00 null 01 write 10 read 11 read/write . END_DESCRIPTION */ /* History: 82-08-20 R. Harvey: Initially written */ /* Parameters */ dcl I_rel_opening_id bit (36) aligned; dcl I_this_process_permission bit (2) aligned; dcl I_other_process_permission bit (2) aligned; dcl O_code fixed bin (35); %page; /* vrm_set_scope: set_scope: proc (I_rel_opening_id, I_this_process_permission, I_other_process_permission, O_code); */ if (I_this_process_permission | I_other_process_permission) = "00"b then O_code = dm_error_$invalid_scope; else call vrm_open_man$get_open_info_ptr (I_rel_opening_id, vrm_open_info_ptr, O_code); if O_code = 0 then do; if substr (I_other_process_permission, 2, 1) = "1"b then vrm_open_info.switches.shared = "1"b; else vrm_open_info.switches.shared = "0"b; end; return; %page; %include vrm_open_info; %page; dcl dm_error_$invalid_scope fixed bin (35) ext static; dcl vrm_open_man$get_open_info_ptr entry (bit (36) aligned, ptr, fixed bin (35)); dcl substr builtin; end vrm_set_scope;  vrmu_add_indexes.pl1 11/23/84 0800.9r w 11/21/84 0933.9 23409 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ vrmu_add_indexes: proc (iocb_ptr, key_list_ptr, tuple_id, code); /* NOTES: This procedure adds all keys in the list pointed to by key_list_ptr to the tuple specified by tuple id. The key is associated with the tuple id, and not with the record directly. */ /* HISTORY: Initially written by JA Weeldreyer -- June, 1978. Renamed and modified for vfile_relmgr_ by R. Harvey -- 20 September 1982. */ %page; /* vrmu_add_indexes: proc (iocb_ptr, key_list_ptr, tuple_id, code); */ /* Parameters */ dcl iocb_ptr ptr; /* vfile iocb */ /* dcl key_list_ptr ptr; /* key values to be added */ dcl tuple_id bit (36) aligned; /* record keys are to be associated with */ dcl code fixed bin (35); /* output error code */ do i = 1 to key_list.number_of_keys; /* add each key in list */ key_list.key_info.vf_info.input_key (i), /* set up info for vfile_ */ key_list.key_info.vf_info.input_desc (i) = "1"b; addr (key_list.key_info.vf_info.vf_desc (i)) -> b36 = tuple_id; /* move in tuple id as descr. */ call iox_$control (iocb_ptr, "add_key", addr (key_list.key_info.vf_info (i)), icode); /* let vfile_ do the work */ if icode ^= 0 then call error (icode); end; /* index additon loop */ code = 0; exit: return; %page; error: proc (cd); /* Internal error procedure */ dcl cd fixed bin (35); code = cd; go to exit; end error; %page; %include vrm_key_list; dcl i fixed bin; dcl b36 bit (36) based; dcl icode fixed bin (35); /* internal status code */ dcl addr builtin; dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); end vrmu_add_indexes;  vrmu_add_tuple.pl1 11/23/84 0800.9rew 11/21/84 0933.9 42831 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ vrmu_add_tuple: proc (vrm_rel_desc_ptr, iocb_ptr, pk_ptr, tuple_id, int_ptr, tuple_len, outt_ptr, code); /* NOTES: This procedure stores a new tuple into the relation indicated by rmri_ptr. The seek_key and write_record operations are used. The tuple_id and a pointer to the stored record are returned to the caller. */ /* HISTORY: Initially written by JA Weeldreyer -- June, 1978. 82-09-20 R. Harvey: Changed module name and stripped down for vfile_relmgr_. 83-06-23 R. Harvey: Changed references to mdbm_error_$dup_store to be dm_error_$key_duplication. 83-10-21 Roger Lackey : Removed the mdbm_tuple_id.incl.pl1 and replaced the needed parts as a automactic based structure */ %page; tuple_ptr = int_ptr; tuple_hdr_len = 4 * (binary (rel (addr (int_ptr -> tuple.data))) - binary (rel (int_ptr))); call iox_$seek_key (iocb_ptr, key, rl_sink, icode); /* search for key */ if icode = 0 then call error (dm_error_$key_duplication); /* if there already */ else if icode ^= error_table_$no_record then call error (icode); /* other error */ call iox_$write_record (iocb_ptr, tuple_ptr, tuple_len, icode); /* write the record */ if icode ^= 0 then call error (icode); string (rs_info.flags) = "0"b; /* get info on rec. just written */ call iox_$control (iocb_ptr, "record_status", addr (rs_info), icode); if icode ^= 0 then call error (icode); outt_ptr = rs_info.record_ptr; /* set output args */ tid_ptr = addr (tuple_id); /* make tuple id */ tuple_id_templet.nstd_desc = "1"b; tuple_id_templet.temp = "0"b; tuple_id_templet.file_id = vrm_rel_desc.file_id; svd_ptr = addr (rs_info.descriptor); tuple_id_templet.comp_no = spec_vf_desc.comp_no; tuple_id_templet.offset = spec_vf_desc.offset; code = 0; exit: return; %page; error: proc (cd); /* Internal error procedure */ dcl cd fixed bin (35); code = cd; go to exit; end error; %page; %include vrm_rel_desc; %page; %include vrm_tuple; %page; %include mdbm_rs_info; %page; dcl tid_ptr ptr; /* Pointer to tuple_id_templet */ dcl 1 tuple_id_templet unal based (tid_ptr), /* tuple id for unblocked files */ 2 nstd_desc bit (1) unal, /* to indicate foreign vfile desc */ 2 temp bit (1) unal, /* On if for temp relation */ 2 file_id bit (7) unal, /* file id no. */ 2 comp_no bit (10), /* vfile component number */ 2 offset bit (17) unal; /* the double word offset within component */ %page; dcl (pk_ptr, /* Input: pointer to encoded primary key */ int_ptr, /* Input: pointer to tuple to be stored */ outt_ptr, /* Output: pointer to stored tuple in db. */ svd_ptr /* pointer to special view of vfile desc. */ ) ptr; dcl (code, /* Output: status code */ icode) fixed bin (35); /* internal status code */ dcl tuple_id bit (36) aligned; /* Output: tuple id of stored tuple */ dcl (rl_sink, /* sink for record length */ tuple_hdr_len, /* length of tuple header */ tuple_len) fixed bin (21); /* true length of tuple */ dcl iocb_ptr ptr; dcl key char (256) var based (pk_ptr); /* encoded primary key */ dcl 1 spec_vf_desc aligned based (svd_ptr), /* special view of vf. desc. */ 2 pad bit (8) unal, 2 comp_no bit (10) unal, 2 offset bit (17) unal; /* drops low order bit */ dcl (dm_error_$key_duplication, error_table_$no_record) ext fixed bin (35); dcl (addr, binary, rel, string ) builtin; dcl iox_$seek_key entry (ptr, char (256) var, fixed bin (21), fixed bin (35)); dcl iox_$write_record entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); end vrmu_add_tuple;  vrmu_build_index_list.pl1 11/23/84 0800.9r w 11/21/84 0933.9 60714 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ vrmu_build_index_list: proc (vrm_rel_desc_ptr, vrm_open_info_ptr, tuple_ptr, change_bits_ptr, key_list_ptr, code); /* NOTES: This procedure builds a list of indexes to be added or deleted from a tuple. */ /* HISTORY: Initially written by JA Weeldreyer -- July, 1978. 6-sept-79 Davids: Modified to accommodate a change to vrmu_encode_key calling sequence 18-oct-79 modified to correctly calculate the lengths of varying strings. 28-nov-79 Davids: Removed calculation of length (in bits) of varying strings so that length word will consistantly contain the number of bits or characters (depending on data type) throughtout MRDS (i hope). 8-may-80 Davids: modified assignments of tuple_num_atts and tuple_nvar_atts to take values from rm_rel_info.model_num_attr and model_nvar_atts rather than rm_rel_info.num_attr and nvar_atts. This was to fix a problem with submodels were the submodel view did not contain a varying string attribute and the model did. Modified by Jim Gray - - June 1980, to make kl_ptr and input parameter, so that the calling routine could decide if the same space for key_list could be reused, which previously limited large modify operations. 81-05-29 Jim Gray : changed to use new resultant structure. 82-09-17 R. Harvey: Renamed from mu_build_indl and modified for use by vfile_relmgr_. */ %page; index_value_length, num_dims = 0; /* This was part of descriptor... */ data_ptr = addr (tuple.data); ksl_number_of_values, kl_number_of_keys = vrm_rel_desc.number_sec_indexes; /* set up the key list */ key_list.number_of_keys = 0; cb_number_of_change_bits = vrm_rel_desc.number_attrs; key_source_list_ptr = addr (local_ksl); /* init for doing sec. indexes */ key_source_list.number_of_values = 1; kv_ptr = addr (local_kv); do i = 1 to vrm_open_info.number_of_index_collections; /* for every secondary index */ vrm_collection_info_ptr = vrm_open_info.index_collection (i).info_ptr; attr_no = vrm_collection_info.attribute (1).attr_index; if change_bits.position (attr_no) then do; call add_key_source_list_item (1, addr (vrm_rel_desc.attr (attr_no))); call make_key_list_entry (vrm_collection_info.id); key_list.key_info.item_index (key_list.number_of_keys) = i; /* fill in index info */ key_list.key_info.cand_key (key_list.number_of_keys), key_list.key_info.unique_val (key_list.number_of_keys) = "0"b; end; /* if index changed */ end; /* adding secondary indexes */ code = 0; exit: return; %page; add_key_source_list_item: proc (ind, raip); /* Procedure to add item to key source list */ dcl ind fixed bin; dcl raip ptr; dcl bit_str bit (raip -> vrm_attr_info.bit_length) based; desc_ptr = addr (raip -> vrm_attr_info.descriptor); key_source_list.val_info.val_ptr (ind) = addr (key_vals (ind)); key_source_list.val_info.desc_ptr (ind) = desc_ptr; if raip -> vrm_attr_info.varying then do; /* move in var. len. attr */ offset = tuple.var_offsets (raip -> vrm_attr_info.bit_offset); key_source_list.val_info.val_ptr (ind) = addr (bit_data (offset)); end; /* moving var. */ else /* moving fixed length */ key_source_list.val_info.val_ptr (ind) -> bit_str = substr (data_str, raip -> vrm_attr_info.bit_offset, raip -> vrm_attr_info.bit_length); end add_key_source_list_item; %page; make_key_list_entry: proc (ind_id); /* Procedure to ad entry to key list */ dcl ind_id bit (8) unal; key_list.number_of_keys = key_list.number_of_keys + 1; call vrmu_encode_key (key_source_list_ptr, key_list.key_info.key (key_list.number_of_keys), not_used, icode); if icode ^= 0 then call error (icode); index_ptr = addr (key_list.key_info.vf_info.key (key_list.number_of_keys)); index_ptr = addrel (index_ptr, 1); /* get past length */ index.index_id = ind_id; index.rel_id = vrm_rel_desc.rel_id; key_list.key_info.vf_info.input_key (key_list.number_of_keys) = "1"b; key_list.key_info.vf_info.input_desc (key_list.number_of_keys) = "0"b; end make_key_list_entry; %page; error: proc (cd); /* error procedure */ dcl cd fixed bin (35); code = cd; go to exit; end error; %page; %include vrm_open_info; %page; %include vrm_rel_desc; %page; %include vrm_collection_info; %page; %include vrm_tuple; %page; %include mdbm_descriptor; %include vrm_index; %include vrm_key_list; %include vrm_key_source_list; %include vrm_change_bits; %page; dcl (data_ptr, /* pointer to tuple.data */ kv_ptr) ptr; /* pointer to aligned key source values */ dcl i fixed bin; /* internal index */ dcl attr_no fixed bin; /* temporary attribute index */ dcl (code, /* Output: status code */ icode, /* internal status code */ offset) fixed bin (35); /* bit position within tuple.data */ dcl key_vals (ksl_number_of_values) char (vrm_data_$max_kattr_length) based (kv_ptr); /* to hold values so they are aligned */ dcl local_kv (4, vrm_data_$max_kattr_length / 8) fixed bin (71); /* to avoid allocations */ dcl 1 local_ksl aligned, /* to avoid allocations */ 2 nvals fixed bin, 2 val_info (4) like key_source_list.val_info; dcl bit_data (vrm_rel_desc.maximum_data_length * 9) bit (1) unal based (data_ptr); /* array view of tupe.data */ dcl data_str bit (vrm_rel_desc.maximum_data_length * 9) based (data_ptr); /* string view */ dcl vrm_data_$max_kattr_length ext fixed bin (35); dcl (addr, addrel, substr) builtin; dcl not_used fixed bin (35); /* parameter to vrmu_encode_key, not used by this routine */ dcl vrmu_encode_key entry (ptr, char (256) var, fixed bin (35), fixed bin (35)); end vrmu_build_index_list;  vrmu_compare_values.pl1 11/23/84 0800.9r w 11/21/84 0934.0 216693 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ vrmu_compare_values: proc (value1_ptr, desc1_ptr, value2_ptr, desc2_ptr, operator, result, code); /* DESCRIPTION */ /* This routine accepts two pointers to some data values and two pointers to the Multics descriptors describing those values, it compares them with respect to the input relational operator. Eithr a result ("1"b or "0"b) or an error code is returned. Character strings may be compared only against other character strings either or both of which may be varying. The same for bit strings. Complex numeric data types may be compared only against other complex data types, also only the operators equal and not_equal may be used, any other operator will cause an error. Real numeric data types may be compared only against other real numeric data types. Any other combination of data types will generate an error. Numeric comparisons are performed by converting the operands into complex/real float decimal (59). All errors are reported to the user via sub_err_ as well as in the returned error code. The internal procedure error performs a non-local goto to compare_values_exit to exit this routine. %page; HISTORY: 16-aug_79 NSDavids Original coding Modified by Jim Gray - - Dec. 1979, to add packed decimal data type capability Modified March 25, 1980 by R. Lackey to remove calls to mdbm_util_ Modified November 24, 1980 by M. Pierret to align result for efficiency 81-05-19 Jim Gray : changed the "&" to "|" in the complex and real data type cases, so that any complex or real number comparisons can be handled. 81-05-20 Jim Gray : added a case for doing bit-char type compares by converting the bit operand to char, and doing a char-char compare. Also added data type to error message for conversion errors. 81-05-23 Jim Gray : added special case for fixed bin, equal scale, comaprisons, for performance improvment, by avoiding calls to mu_convert for this case. This was originally coded by M. Pierret. I adopted it, and made some corrections to the original code, and put it in the subroutine compare_fb_fb. 81-05-23 B Jim Gray : added special case for float bin comparisons, done in a manner similar to the fixed bin case above. 82-09-10 Roger Lackey : Changed to vrmu_compare_values and reformated changed all calls to mu_* to vrmu_* 83-03-27 Roger Lackey : Changed the operator index values from what mrds used to search_specification operator values 1-7 Old New 1 1 = 2 5 ^= 3 7 < 4 6 <= 5 2 > 6 3 >= */ %page; /* vrmu_compare_values: proc (value1_ptr, desc1_ptr, value2_ptr, desc2_ptr, operator, result, code); */ /* PARAMETERS */ dcl value1_ptr ptr; /* (input) pointer to first operand */ dcl desc1_ptr ptr; /* (input) pointer to descriptor of first operand */ dcl value2_ptr ptr; /* (input) ditto for the second operand */ dcl desc2_ptr ptr; /* (input) ditto ditto */ dcl operator fixed bin; /* (input) the relational operator */ /* 1 = */ /* 2 > */ /* 3 >= */ /* 4 ^ NOT VALID operator */ /* 5 ^= */ /* 6 <= */ /* 7 < */ dcl result bit (1) aligned; /* (output) true if comparison was true */ dcl code fixed bin (35); /* (output) error code */ %page; code = 0; /* make sure we don't return garbage */ result = "0"b; desc1 = desc1_ptr -> desc; /* get our own copy of the descriptors */ desc2 = desc2_ptr -> desc; if desc1.type = CHAR_VAR | desc1.type = BIT_VAR /* make varying strings look like non-varying */ then do; operand1_ptr = addr (value1_ptr -> varying_string.data); /* move operand pointer over one word */ string (desc1.size) = substr (value1_ptr -> varying_string.size, 13); /* modify descriptor to show accutal string length */ desc1_type = desc1_type - 1; /* modify type to non-varying */ end; else operand1_ptr = value1_ptr; if desc2.type = CHAR_VAR | desc2.type = BIT_VAR then do; operand2_ptr = addr (value2_ptr -> varying_string.data); string (desc2.size) = substr (value2_ptr -> varying_string.size, 13); desc2_type = desc2_type - 1; end; else operand2_ptr = value2_ptr; if (operator < 1 | operator > 7) | operator = 4 /* make sure we have a legal operator */ then call error (mrds_error_$inv_operator, ltrim (char (operator)) || " is not a valid operator code"); %page; /* Do the comparison */ if desc1.type = CHAR & desc2.type = CHAR then call compare_char_char (operand1_ptr, string (desc1.size), operand2_ptr, string (desc2.size), operator, result); else if desc1.type = BIT & desc2.type = BIT then call compare_bit_bit (operand1_ptr, string (desc1.size), operand2_ptr, string (desc2.size), operator, result); else if COMPLEX (desc1_type) | COMPLEX (desc2_type) /* CHANGE 81-05-19 : allow any complex number comparison */ then do; call vrmu_convert (operand1_ptr, addr (desc1), addr (cfld59a1), addr (CFLD59A_DESC), code); if code ^= 0 then call error (code, "Could not convert a " || vrmu_display_descriptor (desc1_ptr) || " value to a complex float decimal (59) data type"); call vrmu_convert (operand2_ptr, addr (desc2), addr (cfld59a2), addr (CFLD59A_DESC), code); if code ^= 0 then call error (code, "Could not convert a " || vrmu_display_descriptor (desc2_ptr) || " value to a complex float decimal (59) data type"); call compare_c59_c59 (cfld59a1, cfld59a2, operator, result); end; else if REAL (desc1_type) | REAL (desc2_type) /* CHANGE 81-05-19 : allow any real number comparison */ then do; /* BEGIN CHANGE 81-05-23 ********************************************** */ if FIXED_BIN (desc1_type) & FIXED_BIN (desc2_type) & desc1.scale = desc2.scale then call compare_fb_fb (); else if FLOAT_BIN (desc1_type) & FLOAT_BIN (desc2_type) then call compare_flb_flb (); /* END CHANGE 81-05-23 ************************************************ */ else do; call vrmu_convert (operand1_ptr, addr (desc1), addr (rfld59a1), addr (RFLD59A_DESC), code); if code ^= 0 then call error (code, "Could not convert a " || vrmu_display_descriptor (desc1_ptr) || " value to a real float decimal (59) data type"); call vrmu_convert (operand2_ptr, addr (desc2), addr (rfld59a2), addr (RFLD59A_DESC), code); if code ^= 0 then call error (code, "Could not convert a " || vrmu_display_descriptor (desc2_ptr) || " value to a real float decimal (59) data type"); call compare_r59_r59 (rfld59a1, rfld59a2, operator, result); end; end; /* BEGIN CHANGE 81-05-20 ******************************************** */ else if (desc1.type = BIT & desc2.type = CHAR) | (desc1.type = CHAR & desc2.type = BIT) then do; /* do bit-char comparisons as char-char comaprisons, after converting the bit oeprand to character */ if desc1.type = BIT then do; bit_temp_size = bin (string (desc1.size)); char_temp = char (operand1_ptr -> bit_temp); char_temp_size = addr (char_temp) -> overlay.fb24; temp_ptr = addr (char_temp); call compare_char_char (addrel (temp_ptr, 1), char_temp_size, operand2_ptr, string (desc2.size), operator, result); end; else do; bit_temp_size = bin (string (desc2.size)); char_temp = char (operand2_ptr -> bit_temp); char_temp_size = addr (char_temp) -> overlay.fb24; temp_ptr = addr (char_temp); call compare_char_char (operand1_ptr, string (desc1.size), addrel (temp_ptr, 1), char_temp_size, operator, result); end; end; /* END CHANGE 81-05-20 *********************************************** */ else call error (mrds_error_$inv_comparison, "The data types " || vrmu_display_descriptor (desc1_ptr) || " and " || vrmu_display_descriptor (desc2_ptr) || " cannot be compared"); compare_values_exit: return; %page; compare_char_char: proc (c_operand1_ptr, c_operand1_size, c_operand2_ptr, c_operand2_size, c_operator, c_result); /* PARAMETERS */ dcl c_operand1_ptr ptr; dcl c_operand1_size bit (24); dcl c_operand2_ptr ptr; dcl c_operand2_size bit (24); dcl c_operator fixed bin; dcl c_result bit (1) aligned; /* BASED */ dcl c_operand1 char (bin (c_operand1_size)) based (c_operand1_ptr); dcl c_operand2 char (bin (c_operand2_size)) based (c_operand2_ptr); goto c_compare (c_operator); /* value of c_operator was checked when compare_values was entered */ c_compare (1): /* operator: = */ if c_operand1 = c_operand2 then c_result = "1"b; else c_result = "0"b; goto c_exit; c_compare (2): /* operator: > */ if c_operand1 > c_operand2 then c_result = "1"b; else c_result = "0"b; goto c_exit; c_compare (3): /* operator: >= */ if c_operand1 >= c_operand2 then c_result = "1"b; else c_result = "0"b; goto c_exit; c_compare (5): /* operator: ^= */ if c_operand1 ^= c_operand2 then c_result = "1"b; else c_result = "0"b; goto c_exit; c_compare (6): /* operator: <= */ if c_operand1 <= c_operand2 then c_result = "1"b; else c_result = "0"b; goto c_exit; c_compare (7): /* operator: < */ if c_operand1 < c_operand2 then c_result = "1"b; else c_result = "0"b; goto c_exit; c_exit: return; end /* compare_char_char */; %page; compare_bit_bit: proc (b_operand1_ptr, b_operand1_size, b_operand2_ptr, b_operand2_size, b_operator, b_result); /* PARAMETERS */ dcl b_operand1_ptr ptr; dcl b_operand1_size bit (24); dcl b_operand2_ptr ptr; dcl b_operand2_size bit (24); dcl b_operator fixed bin; dcl b_result bit (1) aligned; /* BASED */ dcl b_operand1 bit (bin (b_operand1_size)) based (b_operand1_ptr); dcl b_operand2 bit (bin (b_operand2_size)) based (b_operand2_ptr); goto b_compare (b_operator); /* value of b_operator was checked when compare_values was entered */ b_compare (1): /* operator: = */ if b_operand1 = b_operand2 then b_result = "1"b; else b_result = "0"b; goto b_exit; b_compare (2): /* operator: > */ if b_operand1 > b_operand2 then b_result = "1"b; else b_result = "0"b; goto b_exit; b_compare (3): /* operator: >= */ if b_operand1 >= b_operand2 then b_result = "1"b; else b_result = "0"b; goto b_exit; b_compare (5): /* operator: ^= */ if b_operand1 ^= b_operand2 then b_result = "1"b; else b_result = "0"b; goto b_exit; b_compare (6): /* operator: <= */ if b_operand1 <= b_operand2 then b_result = "1"b; else b_result = "0"b; goto b_exit; b_compare (7): /* operator: < */ if b_operand1 < b_operand2 then b_result = "1"b; else b_result = "0"b; goto b_exit; b_exit: return; end /* compare_bit_bit */; %page; compare_c59_c59: proc (cx_operand1, cx_operand2, cx_operator, cx_result); /* PARAMETERS */ dcl cx_operand1 complex float decimal (59) aligned; dcl cx_operand2 complex float decimal (59) aligned; dcl cx_operator fixed bin; dcl cx_result bit (1) aligned; goto cx_compare (cx_operator); /* value of cx_operator was checked when compare_values was entered */ cx_compare (1): /* operator: = */ if cx_operand1 = cx_operand2 then cx_result = "1"b; else cx_result = "0"b; goto cx_exit; cx_compare (2): /* operator: > */ call error (mrds_error_$inv_operator, "The relational operator > is not allowed for complex data types"); goto cx_exit; cx_compare (3): /* operator: >= */ call error (mrds_error_$inv_operator, "The relational operator >= is not allowed for complex data types"); goto cx_exit; cx_compare (5): /* operator: ^= */ if cx_operand1 ^= cx_operand2 then cx_result = "1"b; else cx_result = "0"b; goto cx_exit; cx_compare (6): /* operator: <= */ call error (mrds_error_$inv_operator, "The relational operator <= is not allowed for complex data types"); goto cx_exit; cx_compare (7): /* operator: < */ call error (mrds_error_$inv_operator, "The relational operator < is not allowed for complex data types"); goto cx_exit; cx_exit: return; end /* compare_c59_c59 */; %page; compare_r59_r59: proc (r_operand1, r_operand2, r_operator, r_result); /* PARAMETERS */ dcl r_operand1 real float decimal (59) aligned; dcl r_operand2 real float decimal (59) aligned; dcl r_operator fixed bin; dcl r_result bit (1) aligned; goto r_compare (r_operator); /* value of r_operator was checked when compare_values was entered */ r_compare (1): /* operator: = */ if r_operand1 = r_operand2 then r_result = "1"b; else r_result = "0"b; goto r_exit; r_compare (2): /* operator: > */ if r_operand1 > r_operand2 then r_result = "1"b; else r_result = "0"b; goto r_exit; r_compare (3): /* operator: >= */ if r_operand1 >= r_operand2 then r_result = "1"b; else r_result = "0"b; goto r_exit; r_compare (5): /* operator: ^= */ if r_operand1 ^= r_operand2 then r_result = "1"b; else r_result = "0"b; goto r_exit; r_compare (6): /* operator: <= */ if r_operand1 <= r_operand2 then r_result = "1"b; else r_result = "0"b; goto r_exit; r_compare (7): /* operator: < */ if r_operand1 < r_operand2 then r_result = "1"b; else r_result = "0"b; goto r_exit; r_exit: return; end /* compare_r59_r59 */; %page; /* BEGIN CHANGE 81-05-23 **************************************************** */ compare_fb_fb: procedure (); /* Comparison of special cased fixed binary values, with equal scales */ dcl fb35a fixed bin (35) aligned based; /* for picking up packed, with prec < 36 */ dcl fb71a fixed bin (71) aligned based; /* for picking up packed, with prec < 71, but >= 36 */ dcl fixed_bin_operand1 fixed bin (71); /* first value to compare */ dcl fixed_bin_operand2 fixed bin (71); /* second value to compare */ dcl bit_operand1 bit (bit_operand1_len) based (operand1_ptr); /* gets significant digits */ dcl bit_operand2 bit (bit_operand2_len) based (operand2_ptr); /* gets significant digits */ dcl bit_operand1_len fixed bin; /* length of significant digit portion */ dcl bit_operand2_len fixed bin; /* length of significant digit portion */ if desc1.packed then do; bit_operand1_len = bin (desc1.precision) + 1; if substr (bit_operand1, 1, 1) then unspec (fixed_bin_operand1) = copy ("1"b, 71 - bin (desc1.precision)) || bit_operand1; else unspec (fixed_bin_operand1) = copy ("0"b, 71 - bin (desc1.precision)) || bit_operand1; end; else if bin (desc1.precision) < 36 then fixed_bin_operand1 = operand1_ptr -> fb35a; else fixed_bin_operand1 = operand1_ptr -> fb71a; if desc2.packed then do; bit_operand2_len = bin (desc2.precision) + 1; if substr (bit_operand2, 1, 1) then unspec (fixed_bin_operand2) = copy ("1"b, 71 - bin (desc2.precision)) || bit_operand2; else unspec (fixed_bin_operand2) = copy ("0"b, 71 - bin (desc2.precision)) || bit_operand2; end; else if bin (desc2.precision) < 36 then fixed_bin_operand2 = operand2_ptr -> fb35a; else fixed_bin_operand2 = operand2_ptr -> fb71a; goto FB_COMPARE (operator); FB_COMPARE (1): /* operator: = */ if fixed_bin_operand1 = fixed_bin_operand2 then result = "1"b; else result = "0"b; goto END_FB_COMPARE; FB_COMPARE (2): /* operator: > */ if fixed_bin_operand1 > fixed_bin_operand2 then result = "1"b; else result = "0"b; goto END_FB_COMPARE; FB_COMPARE (3): /* operator: >= */ if fixed_bin_operand1 >= fixed_bin_operand2 then result = "1"b; else result = "0"b; goto END_FB_COMPARE; FB_COMPARE (5): /* operator: ^= */ if fixed_bin_operand1 ^= fixed_bin_operand2 then result = "1"b; else result = "0"b; goto END_FB_COMPARE; FB_COMPARE (6): /* operator: <= */ if fixed_bin_operand1 <= fixed_bin_operand2 then result = "1"b; else result = "0"b; goto END_FB_COMPARE; FB_COMPARE (7): /* operator: < */ if fixed_bin_operand1 < fixed_bin_operand2 then result = "1"b; else result = "0"b; goto END_FB_COMPARE; END_FB_COMPARE: end; /* END CHANGE 81-05-23 ************************************************** */ %page; /* BEGIN CHANGE 81-05-23 B **************************************************** */ compare_flb_flb: procedure (); /* Comparison of special cased float binary values, with equal scales */ dcl flb27a float bin (27) aligned based; /* for picking up packed, with prec <= 27 */ dcl flb63a float bin (63) aligned based; /* for picking up packed, with prec < 63, but >= 27 */ dcl float_bin_operand1 float bin (63); /* first value to compare */ dcl float_bin_operand2 float bin (63); /* second value to compare */ dcl 1 bit_operand1 unal based (operand1_ptr), /* gets significant digits */ 2 exponent bit (8) unal, 2 mantissa bit (bit_operand1_len); dcl 1 bit_operand2 unal based (operand2_ptr), /* gets significant digits */ 2 exponent bit (8) unal, 2 mantissa bit (bit_operand2_len); dcl bit_operand1_len float bin; /* length of significant digit portion */ dcl bit_operand2_len float bin; /* length of significant digit portion */ if desc1.packed then do; bit_operand1_len = bin (desc1.precision) + 1; if substr (bit_operand1.mantissa, 1, 1) then unspec (float_bin_operand1) = string (bit_operand1) || copy ("1"b, 63 - bin (desc1.precision)); else unspec (float_bin_operand1) = string (bit_operand1) || copy ("0"b, 63 - bin (desc1.precision)); end; else if bin (desc1.precision) <= 27 then float_bin_operand1 = operand1_ptr -> flb27a; else float_bin_operand1 = operand1_ptr -> flb63a; if desc2.packed then do; bit_operand2_len = bin (desc2.precision) + 1; if substr (bit_operand2.mantissa, 1, 1) then unspec (float_bin_operand2) = string (bit_operand2) || copy ("1"b, 63 - bin (desc2.precision)); else unspec (float_bin_operand2) = string (bit_operand2) || copy ("0"b, 63 - bin (desc2.precision)); end; else if bin (desc2.precision) <= 27 then float_bin_operand2 = operand2_ptr -> flb27a; else float_bin_operand2 = operand2_ptr -> flb63a; goto FLB_COMPARE (operator); FLB_COMPARE (1): /* operator: = */ if float_bin_operand1 = float_bin_operand2 then result = "1"b; else result = "0"b; goto END_FLB_COMPARE; FLB_COMPARE (2): /* operator: > */ if float_bin_operand1 > float_bin_operand2 then result = "1"b; else result = "0"b; goto END_FLB_COMPARE; FLB_COMPARE (3): /* operator: >= */ if float_bin_operand1 >= float_bin_operand2 then result = "1"b; else result = "0"b; goto END_FLB_COMPARE; FLB_COMPARE (5): /* operator: ^= */ if float_bin_operand1 ^= float_bin_operand2 then result = "1"b; else result = "0"b; goto END_FLB_COMPARE; FLB_COMPARE (6): /* operator: <= */ if float_bin_operand1 <= float_bin_operand2 then result = "1"b; else result = "0"b; goto END_FLB_COMPARE; FLB_COMPARE (7): /* operator: < */ if float_bin_operand1 < float_bin_operand2 then result = "1"b; else result = "0"b; goto END_FLB_COMPARE; END_FLB_COMPARE: end; /* END CHANGE 81-05-23 B ************************************************** */ %page; error: proc (error_code, message); /* PARAMETERS */ dcl error_code fixed bin (35); dcl message char (*); /* MULTICS ROUTINES */ dcl sub_err_ entry options (variable); /* AUTOMATIC */ dcl retval fixed bin (35); /* needed to make sub_err_ happy */ code = error_code; /* code is global */ call sub_err_ (error_code, "compare_value", "c", null (), retval, message); goto compare_values_exit; /* NON LOCAL GOTO TO EXIT COMPARE_VALUES */ end /* error */; %page; /* BASED */ dcl 01 varying_string based, 02 size bit (36), /* first word is length */ 02 data bit (36); /* rest is data */ dcl 01 desc based, /* a multics descriptor */ 02 version bit (1) unal, 02 type bit (6) unal, 02 packed bit (1) unal, 02 dims bit (4) unal, 02 size, 03 scale bit (12) unal, 03 precision bit (12) unal; dcl desc1_type unsigned fixed bin (6) based (addr (desc1.type)) unal; dcl desc2_type unsigned fixed bin (6) based (addr (desc2.type)) unal; dcl bit_temp bit (bit_temp_size) based; /* overlay for doing bit-char compares */ dcl 1 overlay based, /* overlay for count field of varying string */ 2 unused bit (12), 2 fb24 bit (24); /* only need 24 bits worth */ /* CONSTANTS */ dcl CHAR bit (6) init ("010101"b) internal static options (constant); dcl CHAR_VAR bit (6) init ("010110"b) internal static options (constant); dcl BIT bit (6) init ("010011"b) internal static options (constant); dcl BIT_VAR bit (6) init ("010100"b) internal static options (constant); dcl CFLD59A_DESC bit (36) init ("100110000000000000000000000000111011"b) internal static options (constant); dcl RFLD59A_DESC bit (36) init ("100101000000000000000000000000111011"b) internal static options (constant); dcl REAL (63) bit (1) internal static options (constant) /* true if tuple is real */ init ((4) ("1"b), (4) ("0"b), (2) ("1"b), (2) ("0"b), (30) ("0"b), (2) ("1"b), (19) ("0"b)); dcl COMPLEX (63) bit (1) internal static options (constant) /* true if type is complex */ init ((4) ("0"b), (4) ("1"b), (2) ("0"b), (2) ("1"b), (32) ("0"b), (2) ("1"b), (17) ("0"b)); dcl FIXED_BIN (63) bit (1) int static options (constant) /* true if fixed bin value */ init ((2) ("1"b), (61) ("0"b)); dcl FLOAT_BIN (63) bit (1) int static options (constant) /* true if float bin value */ init ((2) ("0"b), (2) ("1"b), (59) ("0"b)); dcl vrmu_display_descriptor entry (ptr) returns (char (120) varying); dcl mrds_error_$inv_comparison fixed bin (35) external static; dcl mrds_error_$inv_operator fixed bin (35) external static; /* AUTOMATIC */ dcl 01 desc1 like desc; dcl 01 desc2 like desc; dcl operand1_ptr ptr; /* pointer toward what will be used as first operand */ dcl operand2_ptr ptr; /* pointer toward what will be used as second operand */ dcl cfld59a1 complex float decimal (59) aligned; /* place for the first operand if its complex */ dcl cfld59a2 complex float decimal (59) aligned; /* ditto for the second operand */ dcl rfld59a1 real float decimal (59) aligned; /* place for the first operand if its real */ dcl rfld59a2 real float decimal (59) aligned; /* ditto for the second operand */ dcl bit_temp_size fixed bin (24); /* bit length of overlay for bit_char compare */ dcl char_temp char (4096) varying; /* place for char version of bit string */ dcl char_temp_size bit (24); /* temp for char-char compare routine parameter */ /* MRDS ROUTINES */ dcl vrmu_convert entry (ptr, ptr, ptr, ptr, fixed bin (35)); dcl (addr, addrel, bin, char, copy, ltrim, null, string, substr, unspec) builtin; dcl temp_ptr ptr; end vrmu_compare_values;  vrmu_convert.pl1 11/23/84 0800.9r w 11/21/84 0934.0 63027 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* BEGIN DESCRIPTION This procedure converts data located by the source_ptr with a descriptor located by source_desc_ptr, to the data located by target_ptr and described by the descriptor located by target_desc_ptr. The conversion is done using assign_round_. NOTE: assign_ currently only handles data types 1-12, 19-22, 33-34, & 41-46. Error conditions are returned as mrds_error codes, for example, the conversion condition is returned as the error code mrds_error_$conversion_condition. END DESCRIPTION */ /* HISTORY Written by R. D. Lackey June 1979 Modified by Jim Gray Oct. 1979 to add illegal_procedure condition capture. Modified by Rickie E. Brinegar December 8, 1979 to have each condition captured use its own error code. Modified by Jim Gray Dec. 1979, to correct the length parameter handling for assign_, when the data type is string Modified by M Pierret 8 October 1980 to combine all condition handlers into one. Modified by D. Woodka 07/02/82 to change the any-other condition to continue instead of doing a goto EXIT. 82-09-10 Roger Lackey: changed to vrmu_convert */ vrmu_convert: proc (a_source_ptr, a_source_desc_ptr, a_target_ptr, a_target_desc_ptr, a_code); /* PARAMETERS a_source_ptr ptr Pointer to source data a_source_desc_ptr ptr Pointer to source descriptor a_target_ptr ptr Pointer to targer data a_target_desc_ptr ptr Pointer to target descriptor a_code fixed bin (35) Error code */ %page; a_code = 0; source_ptr = a_source_ptr; /* copy arguments */ source_desc_ptr = a_source_desc_ptr; target_ptr = a_target_ptr; target_desc_ptr = a_target_desc_ptr; target_type = 2 * target_desc_ptr -> descriptor.type + fixed (target_desc_ptr -> descriptor.packed); if target_desc_ptr -> descriptor.type >= 19 & target_desc_ptr -> descriptor.type <= 22 then target_length = fixed (string (target_desc_ptr -> descriptor.size)); else do; target_len.scale = addr (target_desc_ptr -> descriptor.scale) -> signed_scale; target_len.precision = fixed (target_desc_ptr -> descriptor.precision); end; source_type = 2 * source_desc_ptr -> descriptor.type + fixed (source_desc_ptr -> descriptor.packed); if source_desc_ptr -> descriptor.type >= 19 & source_desc_ptr -> descriptor.type <= 22 then source_length = fixed (string (source_desc_ptr -> descriptor.size)); else do; source_len.scale = addr (source_desc_ptr -> descriptor.scale) -> signed_scale; source_len.precision = fixed (source_desc_ptr -> descriptor.precision); end; on any_other begin; call find_condition_info_ ((null), addr (cond_info), a_code); do cond_idx = 1 to 7 while (cond_info.condition_name ^= cond_name (cond_idx)); end; if cond_idx > 7 then call continue_to_signal_ (a_code); goto COND (cond_idx); COND (1): /* size */ a_code = mrds_error_$size_condition; goto EXIT; COND (2): /* conversion */ a_code = mrds_error_$conversion_condition; goto EXIT; COND (3): /* fixedoverflow */ a_code = mrds_error_$fixedoverflow_condition; goto EXIT; COND (4): /* error */ a_code = mrds_error_$error_condition; goto EXIT; COND (5): /* illegal_procedure */ a_code = mrds_error_$illegal_procedure_condition; goto EXIT; COND (6): /* overflow */ a_code = mrds_error_$overflow_condition; goto EXIT; COND (7): /* underflow */ a_code = mrds_error_$underflow_condition; goto EXIT; end; /* end of condition handler */ call assign_round_ (target_ptr, target_type, target_length, source_ptr, source_type, source_length); EXIT: return; /* PARAMETERS */ dcl a_source_ptr ptr; /* (INPUT) Pointer to source data */ dcl a_source_desc_ptr ptr; /* (INPUT) Pointer to source descriptor */ dcl a_target_ptr ptr; /* (INPUT) Pointer to target data */ dcl a_target_desc_ptr ptr; /* (INPUT) Pointer to target descriptor */ dcl a_code fixed bin (35); /* (OUTPUT) Error code */ /* OTHERS */ dcl source_desc_ptr ptr; dcl target_desc_ptr ptr; dcl source_ptr ptr; dcl target_ptr ptr; dcl source_type fixed bin; dcl target_type fixed bin; dcl cond_idx fixed bin; dcl source_length fixed bin (35); dcl 1 source_len aligned based (addr (source_length)), /* Length of source */ 2 scale fixed bin (17) unal, 2 precision fixed bin (17) unal; declare signed_scale fixed bin (11) unal based; /* signed fixed binary version of bit(12) */ dcl target_length fixed bin (35); dcl 1 target_len aligned based (addr (target_length)), /* Length of target */ 2 scale fixed bin (17) unal, 2 precision fixed bin (17) unal; dcl 1 cond_info aligned, 2 mc_ptr ptr, 2 version fixed bin, 2 condition_name char (32) varying, 2 info_ptr ptr, 2 wc_ptr ptr, 2 loc_ptr ptr, 2 flags aligned, 3 crawlout bit (1) unal, 3 mbz1 bit (35) unal, 2 mbz2 bit (36) aligned, 2 user_loc_ptr ptr, 2 mbz (4) bit (36) aligned; dcl cond_name (7) char (32) varying int static options (constant) init ("size", "conversion", "fixedoverflow", "error", "illegal_procedure", "overflow", "underflow"); /* Builtin */ dcl (addr, fixed, null, string) builtin; /* External Entries */ dcl assign_round_ entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin, fixed bin (35)); dcl find_condition_info_ entry (ptr, ptr, fixed bin (35)); dcl continue_to_signal_ entry (fixed bin (35)); /* External */ dcl ( mrds_error_$conversion_condition, mrds_error_$error_condition, mrds_error_$fixedoverflow_condition, mrds_error_$illegal_procedure_condition, mrds_error_$overflow_condition, mrds_error_$size_condition, mrds_error_$underflow_condition ) ext fixed bin (35); dcl any_other condition; %include mdbm_descriptor; end vrmu_convert;  vrmu_cv_tuple_to_vector.pl1 11/23/84 0800.9r w 11/21/84 0934.0 124326 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ vrmu_cv_tuple_to_vector: proc; return; /* . BEGIN_DESCRIPTION This routine will convert a data record from vfile_ to a vector format. . END_DESCRIPTION */ /* History: 82-08-26 R. Harvey: Initially written from the mess that was mu_get_data 82-11-01 R. Harvey: Modified to use non-null simple_typed_vector_ptr 83-03-01 R. Harvey: Modified find_and_create_item to use a character string copy where possible. This, along with changing the add_bit_offset_ type calls to use the addbitno builtin caused a significant performance improvement when moving long strings. 83-07-14 R. Harvey: Changed find_and_create_item to use the current length of a varying string instead of the max length. Also, only byte-aligned data is copied by a character move. These changes are due to Bert Moberg. 83-08-17 Bert Moberg: changed the per-attribute move code for increased speed. */ %page; simple_vector: entry (I_tuple_ptr, I_work_area_ptr, I_id_list_ptr, I_rel_desc_ptr, X_simple_typed_vector_ptr, O_code); /* Parameters */ dcl I_tuple_ptr ptr; dcl I_work_area_ptr ptr; dcl I_id_list_ptr ptr; dcl I_rel_desc_ptr ptr; dcl X_simple_typed_vector_ptr ptr; dcl O_code fixed bin (35); /* Copy parameters */ tuple_ptr = I_tuple_ptr; work_area_ptr = I_work_area_ptr; id_list_ptr = I_id_list_ptr; vrm_rel_desc_ptr = I_rel_desc_ptr; simple_typed_vector_ptr = X_simple_typed_vector_ptr; next_put_ptr = null; if id_list_ptr ^= null then /* If an id_list exists check its version */ if id_list.version ^= ID_LIST_VERSION_1 then call error (error_table_$unimplemented_version); if simple_typed_vector_ptr = null () then do; /* Allocate the simple vector in the caller's work area */ if id_list_ptr ^= null then stv_number_of_dimensions = id_list.number_of_ids; /* Number of attributes to make for this tuple */ else stv_number_of_dimensions = vrm_rel_desc.number_attrs; on area call error (error_table_$noalloc); /* Leave this around */ allocate simple_typed_vector in (work_area) set (simple_typed_vector_ptr); simple_typed_vector.type = SIMPLE_TYPED_VECTOR_TYPE; simple_typed_vector.number_of_dimensions = stv_number_of_dimensions; /* Calculate length of data to be returned */ len = 0; do i = 1 to simple_typed_vector.number_of_dimensions; if id_list_ptr ^= null () then attr_id = id_list.id (i); else attr_id = i; descriptor_ptr = addr (vrm_rel_desc.attr (attr_id).descriptor); len = len + align_data_item (descriptor_ptr, len); /* Added necessary pad to align properly */ len = len + vrm_rel_desc.attr (attr_id).bit_length; end; allocate target_str in (work_area) set (next_put_ptr); /* Allocate space for all output values needed */ end; /* Copy specified attributes and set value_ptrs */ data_ptr = addr (tuple.data); do i = 1 to simple_typed_vector.number_of_dimensions; /* Loop for each value to be moved */ if id_list_ptr ^= null () then attr_id = id_list.id (i); else attr_id = i; vrm_attr_info_ptr = addr (vrm_rel_desc.attr (attr_id)); descriptor_ptr = addr (vrm_rel_desc.attr (attr_id).descriptor); if next_put_ptr ^= null () then do; /* no vector was passed in */ position = fixed (bitno (next_put_ptr), 24); next_put_ptr = addbitno (next_put_ptr, align_data_item (descriptor_ptr, position)); simple_typed_vector.dimension (i).value_ptr = next_put_ptr; call find_and_create_item (descriptor_ptr, next_put_ptr, attr_len); next_put_ptr = addbitno (next_put_ptr, attr_len); end; /* no vector */ else do; /* vector passed in - use caller's data ptr */ val_ptr = simple_typed_vector.dimension (i).value_ptr; call find_and_create_item (descriptor_ptr, val_ptr, attr_len); end; end; /* attr. value loop */ X_simple_typed_vector_ptr = simple_typed_vector_ptr; O_code = 0; Exit: return; %page; general_vector: entry (I_tuple_ptr, I_work_area_ptr, I_rel_desc_ptr, I_general_typed_vector_ptr, O_code); /* Parameters */ /* dcl I_tuple_ptr ptr; */ /* dcl I_work_area_ptr ptr; */ /* dcl I_rel_desc_ptr ptr; */ dcl I_general_typed_vector_ptr ptr; /* dcl O_code fixed bin (35); */ /* Copy input parameters */ tuple_ptr = I_tuple_ptr; work_area_ptr = I_work_area_ptr; vrm_rel_desc_ptr = I_rel_desc_ptr; general_typed_vector_ptr = I_general_typed_vector_ptr; /* Calculate the length of data to be returned */ len = 0; do i = 1 to general_typed_vector.number_of_dimensions; attr_id = general_typed_vector.dimension (i).identifier; descriptor_ptr = addr (vrm_rel_desc.attr (attr_id).descriptor); len = len + align_data_item (descriptor_ptr, len); /* Added necessary pad to align properly */ len = len + vrm_rel_desc.attr (attr_id).bit_length; end; on area call error (error_table_$noalloc); allocate target_str in (work_area) set (next_put_ptr); /* Set up space for output values */ /* Copy each attribute selected */ data_ptr = addr (tuple.data); do i = 1 to general_typed_vector.number_of_dimensions; attr_id = general_typed_vector.dimension (i).identifier; vrm_attr_info_ptr = addr (vrm_rel_desc.attr (attr_id)); position = fixed (bitno (next_put_ptr), 24); descriptor_ptr = addr (vrm_rel_desc.attr (attr_id).descriptor); next_put_ptr = addbitno (next_put_ptr, align_data_item (descriptor_ptr, position)); general_typed_vector.dimension (i).value_ptr = next_put_ptr; call find_and_create_item (descriptor_ptr, next_put_ptr, attr_len); next_put_ptr = addbitno (next_put_ptr, attr_len); end; O_code = 0; return; %page; find_and_create_item: proc (desc_ptr, target_data_ptr, len); /* Procedure to move a single value. If the source and target are both byte aligned and a multiple of 9 bits in length, then use a character string overlay to move the data instead of a bit string. */ dcl desc_ptr ptr; /* ptr to descriptor */ dcl len fixed bin (24); dcl (toff, soff) fixed bin (24); dcl bit_str bit (len) based; dcl char_string char (clen) based; dcl clen fixed bin (21); dcl target_data_ptr ptr; dcl vary_length fixed bin (35) unaligned based; dcl equal_0_mod_9 dim (0:36) bit (1) internal static options (constant) init ("1"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "1"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "1"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "1"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "1"b); /* Set up a pointer to the item in the record and determine the length */ if vrm_attr_info.varying /* set pointer to item */ then do; item_ptr = addbitno (data_ptr, tuple.var_offsets (vrm_attr_info.bit_offset) - 1); len = item_ptr -> vary_length; if desc_ptr -> arg_descriptor.type = 22 then len = len * 9; len = len + 36; end; else do; item_ptr = addbitno (data_ptr, vrm_attr_info.bit_offset - 1); /* Note that a -1 is needed because a bit_offset = 1 indicates the first bit which really is an offset of 0. */ len = vrm_attr_info.bit_length; end; /* Now decide how to move the data */ if len >= MIN_CHAR_MOVE then do; /* check for minimum bit count */ toff = fixed (addr (target_data_ptr) -> its.bit_offset); /* number of bits from a word alignment */ soff = fixed (addr (item_ptr) -> its.bit_offset); if equal_0_mod_9 (toff) & equal_0_mod_9 (soff) & mod (len, 9) = 0 then do; clen = divide (len, 9, 21, 0);/* number of characters to move */ target_data_ptr -> char_string = /* move by characters */ item_ptr -> char_string; return; /* EXIT THIS SUBROUTINE */ end; end; /* We get here if we did not do the character move */ target_data_ptr -> bit_str = item_ptr -> bit_str; end find_and_create_item; %page; /* * * * * * * * * * * * * * align_data_item * * * * * * * * * * * */ align_data_item: procedure (arg_descriptor_ptr, base_to_pad) returns (fixed bin); /* HISTORY: Originally written by Jim Gray - - December 1979 */ /* DESCRIPTION: given a pointer to a standard multics pl1 data argument descriptor, and a current storage offset at which data is to be placed, this routine calculates from the data type, and the given address the number of padding bits needed to properly align the data on either a byte, word, or double word boundary, as required by the data type definition, and routines such as assign_. currently the data types that assign_ can handle are supported by this routine(i.e. 1-12, 19-22, 33-34, 43-46) */ /* PARAMETERS: arg_descriptor_ptr - - (input) pointer, points to the standard multics pl1 argument descriptor for the data to be byte/word/even_word aligned using the given address base_to_pad - - (input) fixed bin(35), the current address(offset), of the last data item, after which the data item described by the input descriptor is to be placed, for the first data item, base_to_pad = 0. needed_bits - - (output) fixed bin, the number of bits to add to base_to_pad, in order to obtain the correct byte/word/even_word alignment for the data type as described by the input descriptor. */ %page; /* using the declared alignment and data type for this attribute, return the number of bits necessary to put the data on a boundary as defined by pl1, such as byte, word or double word aligned, for using that type. directly in such operations as the any_to_any convert via assign_ without having to do a bit move to get the proper alignment. this makes data storage in the tuple a true representation of the pl1 attributes of unaligned and aligned for complete user choice in the trade off between speed and space. */ dcl needed_bits fixed bin; /* number of bits needed to get the alignment */ dcl base_to_pad fixed bin (24) parameter; /* original value to be padded out */ needed_bits = 0; /* initialize */ if arg_descriptor_ptr = null () then ; else if arg_descriptor.packed then do; /* unaligned */ if ^(arg_descriptor.type = 21 | (arg_descriptor.type >= 9 & arg_descriptor.type <= 12) /* char or decimal */ | (arg_descriptor.type >= 43 & arg_descriptor.type <= 46)) then ; /* packed decimal */ else needed_bits = pad (BYTE, base_to_pad); end; else do; /* aligned */ if (arg_descriptor.type >= 9 & arg_descriptor.type <= 12) | /* decimal */ (arg_descriptor.type >= 43 & arg_descriptor.type <= 46) | /* packed decimal */ (arg_descriptor.type >= 19 & arg_descriptor.type <= 22) | /* bit or char */ arg_descriptor.type = 1 | arg_descriptor.type = 3 | arg_descriptor.type = 33 then /* binary short */ needed_bits = pad (WORD, base_to_pad); else if arg_descriptor.type = 2 | arg_descriptor.type = 34 | /* binary long */ (arg_descriptor.type >= 4 & arg_descriptor.type <= 8) then /* binary complex */ needed_bits = pad (DOUBLE_WORD, base_to_pad); else ; /* none needed otherwise */ end; return (needed_bits); %page; pad: procedure (pad_size, pad_base) returns (fixed bin); /* routine to return the number of bits necessary to pad a bit count out to an alignment boundary of 9(byte), 36(word), or 72(double word) bits as determined by the pad size input */ if mod (pad_base, pad_size) = 0 then number_of_bits = 0; else do; number_of_bits = pad_size - mod (pad_base, pad_size); end; return (number_of_bits); dcl pad_size fixed bin; /* either 9 or 36 or 72 */ dcl pad_base fixed bin (24); /* current bit length to be padded */ dcl number_of_bits fixed bin; /* what has to be added to get to the desired boundary */ end pad; %page; %include arg_descriptor; dcl BYTE fixed bin init (9) internal static options (constant); /* byte boundary = 9 bits */ dcl WORD fixed bin init (36) int static options (constant); /* word boundary = 36 bits */ dcl DOUBLE_WORD fixed bin init (72) int static options (constant); /* double word boundary = 72 bits */ end align_data_item; %page; error: proc (ecode); dcl ecode fixed bin (35); if simple_typed_vector_ptr ^= null () then free simple_typed_vector; O_code = ecode; go to Exit; end; %page; %include vrm_rel_desc; %page; %include vu_typed_vector; %page; %include dm_id_list; %page; %include vrm_tuple; %page; %include its; %page; %include arg_descriptor; %page; dcl addbitno builtin; dcl area condition; dcl attr_id fixed bin; /* attribute identifier for temp use */ dcl attr_len fixed bin (24); dcl bitno builtin; dcl data_ptr ptr; dcl descriptor_ptr ptr; dcl error_table_$noalloc fixed bin (35) ext static; dcl error_table_$unimplemented_version fixed bin (35) ext static; dcl i fixed bin; /* do index */ dcl item_ptr ptr; dcl len fixed bin (24); dcl MIN_CHAR_MOVE fixed bin int static init (90); /* number of bits */ dcl next_put_ptr ptr; /* used to keep place in output area */ dcl position fixed bin (24); dcl target_str bit (len) based; dcl val_ptr ptr; dcl work_area area based (work_area_ptr); dcl work_area_ptr ptr; dcl (addr, divide, fixed, mod, null) builtin; end vrmu_cv_tuple_to_vector;  vrmu_cv_vector_to_tuple.pl1 11/23/84 0800.9rew 11/21/84 0920.2 127215 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ vrmu_cv_vector_to_tuple: proc (I_rel_desc_ptr, I_tuple_ptr, I_typed_vector_ptr, I_mod_flag, O_tuple_length, O_code); /* NOTES: This procedure inserts user values into the supplied tuple. HISTORY: 82-09-91 R. Harvey: Lifted from mu_build_tuple.pl1 84-08-29 R. Lackey & T. Nguyen: Fixed the out of bound when calculating real_bit_len for the unaligned data type. */ %page; /* Parameters */ dcl I_rel_desc_ptr ptr; dcl I_tuple_ptr ptr; dcl I_typed_vector_ptr ptr; dcl I_mod_flag bit (1) aligned; dcl O_tuple_length fixed bin (21); dcl O_code fixed bin (35); vrm_rel_desc_ptr = I_rel_desc_ptr; tuple_ptr = I_tuple_ptr; /* Determine the type of vector that was passed in */ simple_vector, general_vector = ""b; simple_typed_vector_ptr, general_typed_vector_ptr = I_typed_vector_ptr; if simple_typed_vector.type = SIMPLE_TYPED_VECTOR_TYPE then simple_vector = "1"b; else do; if general_typed_vector.type = GENERAL_TYPED_VECTOR_TYPE then general_vector = "1"b; else call error (dm_error_$bad_vector_type); end; mod_flag = I_mod_flag; on conversion go to conversion_error; data_ptr = addr (tuple.data); if ^mod_flag then do; /* if creating, init tuple */ string (tuple.attr_exists) = "0"b; data_str = "0"b; do i = 1 to vrm_rel_desc.number_var_attrs; tuple.var_offsets (i) = 0; end; tuple.rel_id = vrm_rel_desc.rel_id; end; /* tuple initialization */ %page; if general_vector then num_of_dims = general_typed_vector.number_of_dimensions; else num_of_dims = simple_typed_vector.number_of_dimensions; do i = 1 to num_of_dims; /* beginning of attribute value insertion loop */ if general_vector /* determine attribute number */ then attr_no = general_typed_vector.dimension (i).identifier; else attr_no = i; /* simple vector */ vrm_attr_info_ptr = addr (vrm_rel_desc.attr (attr_no)); /* pick up info ptrs */ tuple.attr_exists (attr_no) = "1"b; /* turn on exist flag */ if general_vector /* point to user value as given */ then db_val_ptr = general_typed_vector.dimension (i).value_ptr; else db_val_ptr = simple_typed_vector.dimension (i).value_ptr; if vrm_attr_info.varying then do; /* insertion of varying length attr. value */ char_count = (addr (vrm_attr_info.descriptor) -> descriptor.type = VAR_CHAR); /* char or bit count */ if char_count then real_bit_len = 9 * db_val_ptr -> fb35u; else real_bit_len = db_val_ptr -> fb35u; if mod_flag then do; /* if updating rather than creating */ offset = tuple.var_offsets (vrm_attr_info.bit_offset); /* offset will be the same */ call word_align (offset); temp_count_word_ptr = add_bit_offset_ (data_ptr, offset - 1); temp_count_word = temp_count_word_ptr -> fb35u; if char_count then temp_count_word = temp_count_word * 9; call compute_shift /* need to compute how much to shift subsequent attributes */ (real_bit_len, temp_count_word, shift_delta); if shift_delta = 0 then /* no shifting, just move new val in */ call insert_var_string; else call shift_insert; /* if shifting required */ end; /* if updating */ else do; /* if creating new tuple */ do j = vrm_attr_info.bit_offset + 1 to vrm_rel_desc.number_var_attrs /* check if a following attr is stored */ while (tuple.var_offsets (j) = 0); end; if j > vrm_rel_desc.number_var_attrs then do; /* if no followers stored */ do j = vrm_attr_info.bit_offset - 1 by -1 to 1 while (tuple.var_offsets (j) = 0); /* check for stored leaders */ end; if j < 1 then do; /* if first var. attr. stored */ offset = vrm_rel_desc.var_offset; /* use initial value */ end; /* if first var. attr. */ else do; /* no followers, but leaders */ /* Find the previous varying attr_no */ do k = attr_no - 1 to 1 by -1; if vrm_rel_desc.attr (k).varying & j = vrm_rel_desc.attr (k).bit_offset then prev_attr_no = k; end; /* check whether previous varying attr is char or bit */ if addr (vrm_rel_desc.attr (prev_attr_no).descriptor) -> descriptor.type = VAR_CHAR then do; temp_count_word_ptr = add_bit_offset_ (data_ptr, tuple.var_offsets (j) - 1); real_bit_len2 = temp_count_word_ptr -> fb35u * 9; end; else do; temp_count_word_ptr = add_bit_offset_ (data_ptr, tuple.var_offsets (j) - 1); real_bit_len2 = temp_count_word_ptr -> fb35u; end; offset = real_bit_len2 + 36 + tuple.var_offsets (j); end; /* no followers but leaders */ call word_align (offset); call insert_var_string; end; /* no following attr. */ else do; /* if there are following attr. */ offset = tuple.var_offsets (j); /* use offset of first follower */ call word_align (offset); call compute_shift (real_bit_len, -36, shift_delta); /* shift followers right to make room */ call shift_insert; end; /* if there were followers */ end; /* if creating */ end; /* insertion of varying attr. val. */ else do; /* insertion of fixed length attr */ if addr (vrm_attr_info.descriptor) -> descriptor.type <= 8 then pad_bit_length = 0; /* non-byte types won't have garbage, and some may be right justified like fixed fin, or split padding like complex */ else pad_bit_length = vrmu_data_length$get_data_pad_length ((vrm_attr_info.descriptor)); substr (data_str, vrm_attr_info.bit_offset, vrm_attr_info.bit_length) = substr (value_for_db, 1, vrm_attr_info.bit_length - pad_bit_length); /* aligned data may have garbage in padding space */ end; end; /* attribute value insertion loop */ /* Now calculate length of the tuple */ tuple_header_length = 4 * (binary (rel (addr (tuple_ptr -> tuple.data))) - binary (rel (tuple_ptr))); if vrm_rel_desc.number_var_attrs <= 0 then /* if fixed len tuple */ tuple_length = tuple_header_length + vrm_rel_desc.maximum_data_length; else do; /* if varying len */ data_ptr = addr (tuple.data); last_len_offset = tuple.var_offsets (vrm_rel_desc.number_var_attrs); last_attr_offset = last_len_offset + 36; last_attr_size_ptr = add_bit_offset_ (data_ptr, last_len_offset - 1); last_attr_len = last_attr_size_ptr -> fb35u; attr_type = addr (vrm_rel_desc.attr (last_var_attr_no).descriptor) -> descriptor.type; if attr_type = 22 /* type = character varying */ then last_attr_len = last_attr_len * 9; last_bit_offset = last_attr_offset + last_attr_len - 1; tuple_length = 4 * (binary (rel (add_bit_offset_ (data_ptr, last_bit_offset - 1))) - binary (rel (tuple_ptr)) + 1); /* length in bytes */ end; /* if varying len */ O_tuple_length = tuple_length; O_code = 0; exit: return; conversion_error: O_code = mdbm_error_$conversion_condition; go to exit; %page; compute_shift: proc (real_bit_len, old_bit_len, shift_delta); /* This routine determines how far right (left for neg values) to shift other attributes to make room for the current attribute. */ dcl real_bit_len fixed bin (35) parm; /* INPUT: length of attribute being inserted */ dcl old_bit_len fixed bin (35) parm; /* INPUT: length of attribute being replaced or zero. */ dcl shift_delta fixed bin (35) parm; /* OUTPUT: amount to shift to make room for new attribute */ dcl (r, o) fixed bin (35); r = real_bit_len + 1; o = old_bit_len + 1; call word_align (r); call word_align (o); shift_delta = r - o; return; end compute_shift; word_align: proc (offset); dcl offset fixed bin (35) parm; /* INPUT-OUTPUT: bit offset within data portion of tuple where attribute will be stored */ dcl slop fixed bin (35); slop = 36 - mod (offset - 1, 36); if slop ^= 36 then offset = offset + slop; return; end word_align; %page; shift_insert: proc; /* Procedure to shift following varying attr. to make room for storing another varying field. */ dcl i fixed bin; if shift_delta < 0 then /* if shifting left */ do i = vrm_attr_info.bit_offset + 1 to vrm_rel_desc.number_var_attrs; /* shift guys to my right */ if tuple.var_offsets (i) > 0 then call shift_attr; end; else /* if shifting right */ do i = vrm_rel_desc.number_var_attrs by -1 to vrm_attr_info.bit_offset + 1; if tuple.var_offsets (i) > 0 then call shift_attr; end; call insert_var_string; shift_attr: proc; /* Procedure to shift an attribute */ dcl (new_offset, shift_len) fixed bin (35); temp_count_word_ptr = add_bit_offset_ (data_ptr, tuple.var_offsets (i) - 1); shift_len = temp_count_word_ptr -> fb35u; /* no. bits being shifted */ if char_count then shift_len = shift_len * 9; /* convert to bit length */ shift_len = shift_len + 36; /* for count field */ new_offset = tuple.var_offsets (i) + shift_delta; /* place to shift to */ /* do an in place move, if not overlapping data involved if the target starts to the right of the source start, and the target start is to the left of the source end we have overlap */ if tuple.var_offsets (i) <= new_offset & tuple.var_offsets (i) + shift_len >= new_offset then call use_temp_for_shift (); else substr (data_str, new_offset, shift_len) = substr (data_str, tuple.var_offsets (i), shift_len); use_temp_for_shift: procedure (); /* routine to use a temporary to avoid problems with in place move that would overwrite data in the process, and result in incorrect move */ dcl temp_string bit (shift_len); temp_string = substr (data_str, tuple.var_offsets (i), shift_len); substr (data_str, new_offset, shift_len) = temp_string; end; tuple.var_offsets (i) = new_offset; end shift_attr; end shift_insert; %page; insert_var_string: proc; /* Procedure to insert new varying string */ tuple.var_offsets (vrm_attr_info.bit_offset) = offset; temp_count_word_ptr = add_bit_offset_ (data_ptr, offset - 1); temp_count_word_ptr -> fb35u = db_val_ptr -> fb35u; substr (data_str, offset + 36, real_bit_len) = substr (value_for_db, 37, real_bit_len); end insert_var_string; error: proc (cd); /* Error procedure */ dcl cd fixed bin (35); O_code = cd; go to exit; end error; %page; %include vrm_rel_desc; %page; %include vu_typed_vector; %page; %include vrm_tuple; %page; dcl ( data_ptr, /* pointer to tuple.data */ db_val_ptr, /* pointer to converted value, ready for tuple */ last_attr_size_ptr /* points to count word of last varying attr */ ) ptr; dcl ( mod_flag, /* Input: on indicats modify rather than store */ simple_vector, general_vector ) bit (1) aligned; dcl (i, j) fixed bin; /* internal indexes */ dcl ( last_attr_len, /* bit length of last varying attribute */ last_attr_offset, /* offset in tuple of value of last varying attribute */ last_bit_offset, /* offset in tuple of last bit of data */ last_len_offset, /* offset in tuple of length of last varying attribute */ offset, /* position to insert new attr. */ real_bit_len, /* bit length of used part of var. string */ real_bit_len2, /* bit length of used part of var. string (again) */ shift_delta, tuple_header_length /* length of header portion of tuple */ ) fixed bin (35); /* bits to shift to make room for new var. attr. */ dcl data_str bit (9 * vrm_rel_desc.maximum_data_length) unal based (data_ptr); /* string view of tuple.data */ dcl temp_count_word_ptr ptr; /* points to count field portion of varying string */ dcl value_for_db bit (vrm_attr_info.bit_length) based (db_val_ptr); /* converted value, ready for tuple */ /* dcl fb35 fixed bin (35) based; templates */ dcl fb35u fixed bin (35) unal based; dcl 1 descriptor aligned based, ( 2 flag bit (1), 2 type fixed bin (6) unsigned, /* data type */ 2 packed bit (1), /* ON = unaligned */ 2 number_dims fixed bin (4) unsigned, /* non-zero for arrays */ 2 size fixed bin (24) unsigned ) unaligned, /* size of data */ 2 array_info (0 refer (descriptor.number_dims)), 3 lower_bound fixed bin (35), 3 upper_bound fixed bin (35), 3 multiplier fixed bin (35); dcl /* interesting data types */ VAR_CHAR init (22) unsigned binary (6) static options (constant); dcl dm_error_$bad_vector_type ext fixed bin (35); dcl mdbm_error_$conversion_condition ext fixed bin (35); dcl conversion condition; dcl (addr, mod, string, substr) builtin; dcl add_bit_offset_ entry (ptr, fixed bin (24)) returns (ptr) reducible; dcl char_count bit (1); /* on => count field of varying string is in chars, else bits */ dcl pad_bit_length fixed bin (35); /* number of bits used in padding aligned data */ dcl vrmu_data_length$get_data_pad_length entry (bit (36)) returns (fixed bin (35)); /* gets padding size for aligned data */ dcl temp_count_word fixed bin (35); /* temporary for varying attr bit length */ dcl attr_no fixed bin; dcl attr_type fixed bin; dcl num_of_dims fixed bin; dcl binary builtin; dcl rel builtin; dcl prev_attr_no fixed bin; dcl k fixed bin; end vrmu_cv_vector_to_tuple;  vrmu_cv_vf_desc_to_ptr.pl1 04/23/85 1414.2rew 04/23/85 1341.9 35694 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ vrmu_cv_vf_desc_to_ptr: proc (I_iocb_ptr, I_vfile_desc, O_record_ptr, O_record_len, O_code); /* BEGIN_DESCRIPTION The purpose of this procedure is to convert a vfile descriptor to a pointer to the vfile_record. END_DESCRIPTION HISTORY 83-05-18 Roger Lackey : Originally written. 84-12-17 Thanh Nguyen : Added code to return code as mrds_error_$inconsistent_data_length in case of record length is zero or record was deleted by another process running in parallel. */ dcl I_iocb_ptr ptr parameter; dcl I_vfile_desc fixed bin (35) aligned parameter; dcl O_record_ptr ptr parameter; dcl O_record_len fixed bin (21) parameter; dcl O_code fixed bin (35) parameter; dcl code fixed bin (35); dcl com_err_ entry () options (variable); O_code, code = 0; O_record_ptr = null; O_record_len = 0; indx_cb_ptr = I_iocb_ptr -> iocb.open_data_ptr; desc = I_vfile_desc; vfd_ptr = addr (desc); loop: if vfd.comp > hbound (seg_ptr_array, 1) then call extend_seg_ptr_array; if seg_ptr_array (vfd.comp) = null then do; call msf_manager_$get_ptr (indx_cb.fcb_ptr, (vfd.comp), DONT_CREATE, seg_ptr_array (vfd.comp), bcnt, O_code); if O_code ^= 0 then return; end; block_ptr = addrel (seg_ptr_array (vfd.comp), vfd.offset); if block_ptr -> record_block_structure.reserved.stationary = "0"b then do; record_len = length (block_ptr -> record_block_structure.block_tail.record); O_record_ptr = addrel (addr (block_ptr -> record_block_structure.block_tail.record), 1); end; else do; if block_ptr -> record_block_structure.reserved.indirect then do; desc = block_ptr -> ind_structure.prev_desc; goto loop; end; record_len = length (block_ptr -> stat_structure.record); O_record_ptr = addrel (addr (block_ptr -> stat_structure.record), 1); end; if record_len = 0 | block_ptr -> block_head.is_this_block_free = "1"b then O_code = mrds_error_$inconsistent_data_length; else O_record_len = record_len; return; %page; extend_seg_ptr_array: proc; old_array_limit = seg_ptr_array_limit; old_array_ptr = seg_ptr_array_ptr; f_b_ptr = indx_cb.file_base_ptr; seg_ptr_array_limit = file_base.last_comp_num; allocate seg_ptr_array in (get_system_free_area_ () -> cb_area) set (seg_ptr_array_ptr); do i = 0 to old_array_limit; seg_ptr_array (i) = old_array (i); end; do i = old_array_limit + 1 to seg_ptr_array_limit; seg_ptr_array (i) = null (); end; free old_array; /* in systemfree */ dcl cb_area area based; dcl get_system_free_area_ entry () returns (ptr); dcl i fixed bin; dcl old_array_limit fixed bin; dcl old_array_ptr ptr; dcl old_array (0:old_array_limit) ptr based (old_array_ptr); end extend_seg_ptr_array; %page; %include vfile_indx; %page; %include vfile_indx_block_header; %page; %include iocb; %page; dcl vfd_ptr ptr; dcl 1 vfd based (vfd_ptr), 2 comp fixed bin (17) unal, 2 offset bit (18) unal; dcl addrel builtin; dcl bcnt fixed bin (24); dcl DONT_CREATE bit (1) int static options (constant) init ("0"b); dcl msf_manager_$get_ptr entry (ptr, fixed bin, bit (1), ptr, fixed bin (24), fixed bin (35)); dcl pos_ptr ptr; /* This var is not referenced but a compiler warning is issued if it isn't here */ dcl block_ptr ptr; dcl mrds_error_$inconsistent_data_length fixed bin (35) ext static; dcl hbound builtin; dcl record_len fixed bin (21); dcl desc fixed bin (35) aligned; end vrmu_cv_vf_desc_to_ptr;  vrmu_data_align.pl1 11/23/84 0800.9r w 11/21/84 0934.0 45747 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* HISTORY: Originally written by Jim Gray - - December 1979 Renamed for vfile_relmgr_ by R. Harvey -- November 1982 */ vrmu_data_align: align_data_item: procedure (desc_ptr, base_to_pad) returns (fixed bin); /* DESCRIPTION: given a pointer to a standard multics pl1 data argument descriptor, and a current storage offset at which data is to be placed, this routine calculates from the data type, and the given address the number of padding bits needed to properly align the data on either a byte, word, or double word boundary, as required by the data type definition, and routines such as assign_. currently the data types that assign_ can handle are supported by this routine(i.e. 1-12, 19-22, 33-34, 43-46) */ /* PARAMETERS: desc_ptr - - (input) pointer, points to the standard multics pl1 argument descriptor for the data to be byte/word/even_word aligned using the given address base_to_pad - - (input) fixed bin(35), the current address(offset), of the last data item, after which the data item described by the input descriptor is to be placed, for the first data item, base_to_pad = 0. needed_bits - - (output) fixed bin, the number of bits to add to base_to_pad, in order to obtain the correct byte/word/even_word alignment for the data type as described by the input descriptor. */ /* using the declared alignment and data type for this attribute, return the number of bits necessary to put the data on a boundary as defined by pl1, such as byte, word or double word aligned, for using that type. directly in such operations as the any_to_any convert via assign_ without having to do a bit move to get the proper alignment. this makes data storage in the tuple a true representation of the pl1 attributes of unaligned and aligned for complete user choice in the trade off between speed and space. */ needed_bits = 0; /* initialize */ if desc_ptr = null () then ; else if descriptor.packed then do; /* unaligned */ if ^(descriptor.type = 21 | (descriptor.type >= 9 & descriptor.type <= 12) /* char or decimal */ | (descriptor.type >= 43 & descriptor.type <= 46)) then ; /* packed decimal */ else needed_bits = pad (BYTE, base_to_pad); end; else do; /* aligned */ if (descriptor.type >= 9 & descriptor.type <= 12) | /* decimal */ (descriptor.type >= 43 & descriptor.type <= 46) | /* packed decimal */ (descriptor.type >= 19 & descriptor.type <= 22) | /* bit or char */ descriptor.type = 1 | descriptor.type = 3 | descriptor.type = 33 then /* binary short */ needed_bits = pad (WORD, base_to_pad); else if descriptor.type = 2 | descriptor.type = 34 | /* binary long */ (descriptor.type >= 4 & descriptor.type <= 8) then /* binary complex */ needed_bits = pad (DOUBLE_WORD, base_to_pad); else ; /* none needed otherwise */ end; return (needed_bits); declare null builtin; declare needed_bits fixed bin; /* number of bits needed to get the alignment */ declare base_to_pad fixed bin (35); /* original value to be padded out */ pad: procedure (pad_size, pad_base) returns (fixed bin); /* routine to return the number of bits necessary to pad a bit count out to an alignment boundary of 9(byte), 36(word), or 72(double word) bits as determined by the pad size input */ if mod (pad_base, pad_size) = 0 then number_of_bits = 0; else do; number_of_bits = pad_size - mod (pad_base, pad_size); end; return (number_of_bits); declare mod builtin; declare pad_size fixed bin; /* either 9 or 36 or 72 */ declare pad_base fixed bin (35); /* current bit length to be padded */ declare number_of_bits fixed bin; /* what has to be added to get to the desired boundary */ end; declare BYTE fixed bin init (9) internal static options (constant); /* byte boundary = 9 bits */ declare WORD fixed bin init (36) int static options (constant); /* word boundary = 36 bits */ declare DOUBLE_WORD fixed bin init (72) int static options (constant); /* double word boundary = 72 bits */ %include mdbm_descriptor; end vrmu_data_align;  vrmu_data_class.pl1 11/23/84 0800.9r w 11/21/84 0934.0 67446 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* HISTORY: Originally written by Jim Gray - - December 1979 Renamed from mu_data_class for use in vfile_relmgr_ by Ron Harvey - 1983 */ vrmu_data_class: procedure (); return; /* not a valid entry */ /* DESCRIPTION: this routine, given a standard multics pl1 argument descriptor, will determine whether the descriptor refers to the class of data, that the particular entry refers to, and return either a true or false value. there are 12 entries: real - determines if the data type is real complex - determines if the data type is complex char - determines determines if the data type is character bit - determines if the data type is bit varying - determines if the data type is bit or character varying aligned - determines if the data type is unpacked fixed - determines if the data type is numeric and fixed point scalar - determines if the data is not an array string - determines if the data is a string type(bit or char) number - determines if the data is a number(real or complex) convertible - determines if the data can be converted to float decimal(59) binary - determines if the data is a binary number */ /* PARAMETERS: desc_ptr - - (input) pointer, points to the bit(36) standard multics pl1 descriptor for data, which is to be queried for it's data class valid - - (output) bit(1) aligned, either true or false, true if the descriptor refered to a data type in the class determined by the entry called, which is one of real, complex, char, bit, varying, aligned, fixed, scalar string, number, convertible, or binary */ %page; /* check for data being numeric, and real */ real: real_data_class: entry (desc_ptr) returns (bit (1) aligned); class = type_to_class (descriptor.type); if abs (class) = REAL then valid = ON; else valid = OFF; return (valid); /* check for data being numeric, and complex */ complex: complex_data_class: entry (desc_ptr) returns (bit (1) aligned); class = type_to_class (descriptor.type); if abs (class) = COMPLEX then valid = ON; else valid = OFF; return (valid); /* check for data being character */ character: character_data_class: entry (desc_ptr) returns (bit (1) aligned); class = type_to_class (descriptor.type); if abs (class) = CHAR then valid = ON; else valid = OFF; return (valid); /* check for data being bit */ bit: bit_data_class: entry (desc_ptr) returns (bit (1) aligned); class = type_to_class (descriptor.type); if abs (class) = BIT then valid = ON; else valid = OFF; return (valid); /* check for data being varying character or bit */ varying: varying_data_class: entry (desc_ptr) returns (bit (1) aligned); class = type_to_class (descriptor.type); if class < VARYING then valid = ON; else valid = OFF; return (valid); %page; /* check for data being aligned or unaligned */ aligned: aligned_data_class: entry (desc_ptr) returns (bit (1) aligned); valid = ^(descriptor.packed); return (valid); /* check for data being scalar */ scalar: scalar_data_class: entry (desc_ptr) returns (bit (1) aligned); if fixed (descriptor.number_dims) = 0 then valid = ON; else valid = OFF; return (valid); /* check for number data being fixed point */ fixed: fixed_data_class: entry (desc_ptr) returns (bit (1) aligned); class = type_to_class (descriptor.type); if class > 0 & class <= FIXED then valid = ON; else valid = OFF; return (valid); /* check for data being a string type */ string: string_data_class: entry (desc_ptr) returns (bit (1) aligned); class = type_to_class (descriptor.type); if abs (class) > STRING then valid = ON; else valid = OFF; return (valid); /* check for the data being any type of number */ number: number_data_class: entry (desc_ptr) returns (bit (1) aligned); class = type_to_class (descriptor.type); if class ^= 0 & abs (class) <= NUMBER then valid = ON; else valid = OFF; return (valid); %page; /* check for data type being convertable to float decimal (59) */ convertible: convertible_data_class: entry (desc_ptr) returns (bit (1) aligned); class = type_to_class (descriptor.type); if abs (class) = REAL | abs (class) = CHAR then valid = ON; else valid = OFF; return (valid); /* check for data type being a binary number */ binary: binary_data_class: entry (desc_ptr) returns (bit (1) aligned); if (descriptor.type >= 1 & descriptor.type <= 8) | descriptor.type = 33 | descriptor.type = 34 then valid = ON; else valid = OFF; return (valid); %page; dcl class fixed bin; /* class encoding taken from data type */ dcl STRING fixed bin int static options (constant) init (2); /* encoding for string check */ dcl NUMBER fixed bin int static options (constant) init (2); /* encoding for number check */ dcl REAL fixed bin internal static options (constant) init (1); /* encoding for real numerics */ dcl COMPLEX fixed bin internal static options (constant) init (2); /* encoding for complex numerics */ dcl BIT fixed bin internal static options (constant) init (3); /* encoding for bit strings */ dcl CHAR fixed bin internal static options (constant) init (4); /* encoding for character strings */ dcl VARYING fixed bin internal static options (constant) init (-2); /* encoding for varying string comparison */ dcl FIXED fixed bin internal static options (constant) init (2); /* encoding for varying string comparison */ dcl valid bit (1) aligned; /* on => class matches entry called */ dcl ON bit (1) init ("1"b) internal static options (constant); /* true value */ dcl OFF bit (1) init ("0"b) internal static options (constant); /* false value */ dcl (abs, fixed) builtin; /* the following encoding array, takes a data type as it's index, and returns as an element value, the following classifying values: real fixed = 1, real float = -1, complex fixed = 2, complex float = -2, bit = 3, bit varying = -3, character = 4, character varying = -4, no class = 0 */ dcl type_to_class (0:63) aligned internal static options (constant) fixed bin init (0, (2) (1), (2) (-1), /* 0 - 4 */ (2) (2), (2) (-2), /* 5 - 8 */ 1, -1, 2, -2, (6) (0), /* 9 - 12, 13 - 18 */ 3, -3, 4, -4, /* 19 - 22 */ (6) (0), /* 23 - 28 */ (2) (1), (2) (0), /* 29 - 32 */ (4) (1), 0, /* 33 - 37 */ (4) (1), /* 38 - 41 */ -1, 1, -1, 2, -2, /* 42 - 46 */ (17) (0)); /* 47 - 63 */ %include mdbm_descriptor; end vrmu_data_class;  vrmu_data_length.pl1 11/23/84 0800.9r w 11/21/84 0934.1 149886 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* HISTORY: originally written by jim gray - - April 1979 Modified by Rickie E. Brinegar on December 28, 1979 to make code a non static variable as opposed to the declaration of int static options (constant) it was originally declared as. Modified by Rickie E. Brinegar on January 9, 1980 to change the declaration of return_value from in static options (constant) to automatic. Modified by Jim Gray - - 80-9-18, to add the $get_data_pad_length entry, so that mu_build_tuple count have a common data primitive routine to get the amount of padding for aligned data types from. Modified by R. Harvey -- 83-04-03 renamed from mu_data_class and cleaned up some not-completely-qualified structure element references. */ vrmu_data_length: get_data_bit_length: procedure (input_descriptor) returns (fixed bin (35)); /* DESCRIPTION: given a 36-bit multics pl1 argument descriptor this routine determines the number of bits of storage that the data type, alignment, and precision or size requires when residing in memory, not counting words skipped to obtain even word boundaries. the descriptor is assumed to be valid, with correct values for scale, precision, size, etc. for that data type, since this is to be an efficient run-time routine having had error checks made elsewhere. also, the data is assumed to be scalar, i.e. that there are no array bounds, as this will be expanded elsewhere. decimal 4-bit non-byte aligned are treated as byte aligned data. The entry $get_data_pad_length returns instead of the storage bit length, the amount of padding that aligned data types needed. */ /* PARAMETERS: input_descriptor - - (input) bit(36) multics pl1 argument descriptor, see subsystem writers guide for format. bit_length - - (output) returned storage space needed in bits, declared fixed bin(35). pad_length - - (output) fixed bin(35), for the $get_data_pad_length only, this is the number of bits required to pad aligned data out to it's full size. it will be 0 for unaligned data types ; sub_error_ - - (output) condition, signaled upon occurence of error */ /* get local version of the descriptor */ descriptor = input_descriptor; call common (); return (bit_length); /* entry to return the amount of padding space used */ get_data_pad_length: entry (entry_descriptor) returns (fixed bin (35)); descriptor = entry_descriptor; pad_length = 0; /* for unaligned types */ call common (); return (pad_length); common: procedure (); /* CASE STRUCTURE BASED ON THE DATA TYPE */ goto case (descriptor_type.type); /* UNUSED */ case (0): call unimplemented_data_type (); goto end_case; /* REAL FIXED BINARY SHORT */ case (1): bit_length = descriptor_precision.precision + SIGN; if descriptor_packed_flag.packed then ; else do; pad_length = ONE_WORD - bit_length; bit_length = ONE_WORD; end; goto end_case; /* REAL FIXED BINARY LONG */ case (2): bit_length = descriptor_precision.precision + SIGN; if descriptor_packed_flag.packed then ; else do; pad_length = TWO_WORD - bit_length; bit_length = TWO_WORD; end; goto end_case; /* REAL FLOATING BINARY SHORT */ case (3): bit_length = descriptor_precision.precision + ONE_BYTE; if descriptor_packed_flag.packed then ; else do; pad_length = ONE_WORD - bit_length; bit_length = ONE_WORD; end; goto end_case; /* REAL FLOATING BINARY LONG */ case (4): bit_length = descriptor_precision.precision + ONE_BYTE; if descriptor_packed_flag.packed then ; else do; pad_length = TWO_WORD - bit_length; bit_length = TWO_WORD; end; goto end_case; /* COMPLEX FIXED BINARY SHORT */ case (5): bit_length = DOUBLE * (descriptor_precision.precision + SIGN); if descriptor_packed_flag.packed then ; else do; pad_length = TWO_WORD - bit_length; bit_length = TWO_WORD; end; goto end_case; /* COMPLEX FIXED BINARY LONG */ case (6): bit_length = DOUBLE * (descriptor_precision.precision + SIGN); if descriptor_packed_flag.packed then ; else do; pad_length = FOUR_WORD - bit_length; bit_length = FOUR_WORD; end; goto end_case; /* COMPLEX FLOATING BINARY SHORT */ case (7): bit_length = DOUBLE * (descriptor_precision.precision + ONE_BYTE); if descriptor_packed_flag.packed then ; else do; pad_length = TWO_WORD - bit_length; bit_length = TWO_WORD; end; goto end_case; /* COMPLEX FLOATING BINARY LONG */ case (8): bit_length = DOUBLE * (descriptor_precision.precision + ONE_BYTE); if descriptor_packed_flag.packed then ; else do; pad_length = FOUR_WORD - bit_length; bit_length = FOUR_WORD; end; goto end_case; /* REAL FIXED DECIMAL */ case (9): bit_length = ONE_BYTE * (descriptor_precision.precision + SIGN); if descriptor_packed_flag.packed then ; else call pad_to_word_boundary (); goto end_case; /* REAL FLOATING DECIMAL */ case (10): bit_length = ONE_BYTE * (descriptor_precision.precision + SIGN_AND_EXPONENT); if descriptor_packed_flag.packed then ; else call pad_to_word_boundary (); goto end_case; /* COMPLEX FIXED DECIMAL */ case (11): bit_length = DOUBLE * ONE_BYTE * (descriptor_precision.precision + SIGN); if descriptor_packed_flag.packed then ; else call pad_to_word_boundary (); goto end_case; /* COMPLEX FLOATING DECIMAL */ case (12): bit_length = DOUBLE * ONE_BYTE * (descriptor_precision.precision + SIGN_AND_EXPONENT); if descriptor_packed_flag.packed then ; else call pad_to_word_boundary (); goto end_case; /* POINTER */ case (13): if descriptor_packed_flag.packed then bit_length = ONE_WORD; else bit_length = TWO_WORD; goto end_case; /* OFFSET */ case (14): if descriptor_packed_flag.packed then call invalid_alignment (); else bit_length = ONE_WORD; goto end_case; /* LABEL */ case (15): if descriptor_packed_flag.packed then call invalid_alignment (); else bit_length = FOUR_WORD; goto end_case; /* ENTRY */ case (16): if descriptor_packed_flag.packed then call invalid_alignment (); else bit_length = FOUR_WORD; goto end_case; /* NOTE: this length is correct for structures declared without arrays only. (i.e. only scalar elements) */ /* STRUCTURE */ case (17): bit_length = ONE_WORD * descriptor_size.size; goto end_case; /* AREA */ case (18): bit_length = ONE_WORD * descriptor_size.size; goto end_case; /* BIT STRING */ case (19): bit_length = descriptor_size.size; if descriptor_packed_flag.packed then ; else call pad_to_word_boundary (); goto end_case; /* VARYING BIT STRING */ case (20): bit_length = descriptor_size.size + ONE_WORD; if descriptor_packed_flag.packed then call invalid_alignment (); else call pad_to_word_boundary (); goto end_case; /* CHARACTER STRING */ case (21): bit_length = ONE_BYTE * descriptor_size.size; if descriptor_packed_flag.packed then ; else call pad_to_word_boundary (); goto end_case; /* VARYING CHARACTER STRING */ case (22): bit_length = (ONE_BYTE * descriptor_size.size) + ONE_WORD; if descriptor_packed_flag.packed then call invalid_alignment (); else call pad_to_word_boundary (); goto end_case; /* FILE */ case (23): bit_length = FOUR_WORD; goto end_case; /* UNUSED */ case (24): case (25): case (26): case (27): case (28): call unimplemented_data_type (); goto end_case; /* REAL FIXED DECIMAL LEADING OVERPUNCHED SIGN 9-BIT */ case (29): bit_length = ONE_BYTE * descriptor_precision.precision; if descriptor_packed_flag.packed then ; else call pad_to_word_boundary (); goto end_case; /* REAL FIXED DECIMAL TRAILING OVERPUNCHED SIGN 9-BIT */ case (30): bit_length = ONE_BYTE * descriptor_precision.precision; if descriptor_packed_flag.packed then ; else call pad_to_word_boundary (); goto end_case; /* UNUSED */ case (31): case (32): call unimplemented_data_type (); goto end_case; /* REAL FIXED BINARY SHORT UNSIGNED */ case (33): bit_length = descriptor_precision.precision; if descriptor_packed_flag.packed then ; else do; pad_length = ONE_WORD - bit_length; bit_length = ONE_WORD; end; goto end_case; /* REAL FIXED BINARY LONG UNSIGNED */ case (34): bit_length = descriptor_precision.precision; if descriptor_packed_flag.packed then ; else do; pad_length = TWO_WORD - bit_length; bit_length = TWO_WORD; end; goto end_case; /* REAL FIXED DECIMAL UNSIGNED 9-BIT */ case (35): bit_length = ONE_BYTE * descriptor_precision.precision; if descriptor_packed_flag.packed then ; else call pad_to_word_boundary (); goto end_case; /* REAL FIXED DECIMAL TRAILING SIGN 9-BIT */ case (36): bit_length = ONE_BYTE * (descriptor_precision.precision + SIGN); if descriptor_packed_flag.packed then ; else call pad_to_word_boundary (); goto end_case; /* UNUSED */ case (37): call unimplemented_data_type (); goto end_case; /* NOTE: non-byte-aligned decimal 4-bit requires knowledge of physical 1/2 byte alignment to determine actual bit length, thus it is unsupported by pl1, and MRDS, and the returned bit length will be the same as if it were the corresponding byte aligned decimal 4-bit data type. */ /* REAL FIXED DECIMAL UNSIGNED 4-BIT */ case (38): bit_length = ONE_BYTE * floor ((descriptor_precision.precision + PAD) / PER_BYTE_FACTOR); if descriptor_packed_flag.packed then ; else call pad_to_word_boundary (); goto end_case; /* REAL FIXED DECIMAL TRAILING SIGN 4-BIT */ case (39): bit_length = ONE_BYTE * floor ((descriptor_precision.precision + SIGN_AND_PAD) / PER_BYTE_FACTOR); if descriptor_packed_flag.packed then ; else call pad_to_word_boundary (); goto end_case; /* UNUSED */ case (40): call unimplemented_data_type (); goto end_case; /* REAL FIXED DECIMAL LEADING SIGN 4-BIT */ case (41): bit_length = ONE_BYTE * floor ((descriptor_precision.precision + SIGN_AND_PAD) / PER_BYTE_FACTOR); if descriptor_packed_flag.packed then ; else call pad_to_word_boundary (); goto end_case; /* REAL FLOATING DECIMAL 4-BIT */ case (42): bit_length = ONE_BYTE * floor ((descriptor_precision.precision + SIGN_EXPONENT_AND_PAD) / PER_BYTE_FACTOR); if descriptor_packed_flag.packed then ; else call pad_to_word_boundary (); goto end_case; /* REAL FIXED DECIMAL LEADING SIGN 4-BIT BYTE-ALIGNED */ case (43): bit_length = ONE_BYTE * floor ((descriptor_precision.precision + SIGN_AND_PAD) / PER_BYTE_FACTOR); if descriptor_packed_flag.packed then ; else call pad_to_word_boundary (); goto end_case; /* REAL FLOATING DECIMAL 4-BIT BYTE-ALIGNED */ case (44): bit_length = ONE_BYTE * floor ((descriptor_precision.precision + SIGN_EXPONENT_AND_PAD) / PER_BYTE_FACTOR); if descriptor_packed_flag.packed then ; else call pad_to_word_boundary (); goto end_case; /* COMPLEX FIXED DECIMAL LEADING SIGN 4-BIT BYTE-ALIGNED */ case (45): bit_length = DOUBLE * ONE_BYTE * floor ((descriptor_precision.precision + SIGN_AND_PAD) / PER_BYTE_FACTOR); if descriptor_packed_flag.packed then ; else call pad_to_word_boundary (); goto end_case; /* COMPLEX FLOATING DECIMAL 4-BIT BYTE-ALIGNED */ case (46): bit_length = DOUBLE * ONE_BYTE * floor ((descriptor_precision.precision + SIGN_EXPONENT_AND_PAD) / PER_BYTE_FACTOR); if descriptor_packed_flag.packed then ; else call pad_to_word_boundary (); goto end_case; /* UNUSED */ case (47): case (48): case (49): case (50): case (51): case (52): case (53): case (54): case (55): case (56): case (57): case (58): case (59): case (60): case (61): case (62): case (63): call unimplemented_data_type (); goto end_case; /* END OF DESCRIPTOR TYPE CASE STATEMENT */ end_case: end; pad_to_word_boundary: procedure (); /* fill out the bit length to reflect a word boundary aligned, integral number of words storage space */ if mod (bit_length, ONE_WORD) = 0 then ; else do; pad_length = (ONE_WORD - mod (bit_length, ONE_WORD)); bit_length = bit_length + pad_length; end; end; unimplemented_data_type: procedure (); /* report that an unused data type was given in the descriptor */ code = mrds_error_$invalid_dm_descriptor; call sub_err_ (code, caller_name, continue, info_ptr, return_value, "^/An invalid data type = ^d, ""^a"", was given in the descriptor.", descriptor_type.type, mu_display_descriptor (addr (descriptor))); bit_length, pad_length = 0; end; invalid_alignment: procedure (); /* report incorrect use of the packed feature */ code = mrds_error_$invalid_dm_descriptor; call sub_err_ (code, caller_name, continue, info_ptr, return_value, "^/The unaligned (packed) attribute can not be used with the data type = ""^a"".", mu_display_descriptor (addr (descriptor))); bit_length, pad_length = 0; end; declare SIGN_AND_PAD fixed bin init (2) int static options (constant); /* sign digit + 1/2 byte padding */ declare SIGN_EXPONENT_AND_PAD fixed bin init (4) int static options (constant); /* sign digit, exp byte, + 1/2 byte pad */ declare PAD fixed bin init (1) int static options (constant); /* 1/2 byte padding */ declare PER_BYTE_FACTOR fixed bin init (2) int static options (constant); /* number of digits per byte */ declare SIGN_AND_EXPONENT fixed bin init (2) int static options (constant); /* float decimal exp and sign char space */ declare DOUBLE fixed bin init (2) int static options (constant); /* multiplier for complex numbers */ declare SIGN fixed bin init (1) int static options (constant); /* space for sign */ declare input_descriptor bit (36); /* users descriptor parameter */ declare code fixed bin (35) init (0); /* error encoding */ declare caller_name char (14) init ("mu_data_length") int static options (constant); /* name of calling routine */ declare continue char (1) init ("c") int static options (constant); /* after printing, keep going */ declare info_ptr ptr init (null ()) int static options (constant); /* unused */ declare return_value fixed bin (35) init (0); declare bit_length fixed bin (35); /* returned storage length */ declare sub_err_ entry options (variable); /* error reporting routine */ declare (mod, addr, floor) builtin; declare descriptor bit (36); /* basic multics pl1 descriptor */ declare ONE_WORD fixed bin init (36) int static options (constant); /* bit length of a word */ declare TWO_WORD fixed bin init (72) int static options (constant); /* bit length of two words */ declare FOUR_WORD fixed bin init (144) int static options (constant); /* bit length of four words */ declare ONE_BYTE fixed bin init (9) int static options (constant); /* bit length of a byte (character) */ declare 1 descriptor_precision unal based (addr (descriptor)), /* overlay for arith precision */ 2 unused bit (24) unal, /* skip over first part */ 2 precision unsigned fixed bin (12) unal; /* arith precision */ declare 1 descriptor_packed_flag unal based (addr (descriptor)), /* overlay for packed */ 2 unused_1 bit (7) unal, 2 packed bit (1) unal, /* ON => unaligned */ 2 unused_2 bit (28) unal; declare 1 descriptor_type unal based (addr (descriptor)), /* overlay for descriptor type */ 2 unused_1 bit (1) unal, 2 type unsigned fixed bin (6) unal, /* descriptor type code */ 2 unused_2 bit (29) unal; declare mrds_error_$invalid_dm_descriptor fixed bin (35) ext; /* bad data type */ declare mu_display_descriptor entry (ptr) returns (char (120) varying); /* for trouble reporting */ declare 1 descriptor_size unal based (addr (descriptor)), /* string/area/structure size overlay */ 2 unused bit (12) unal, 2 size unsigned fixed bin (24) unal; /* size field */ declare pad_length fixed bin (35); /* length to pad aligned data types */ declare entry_descriptor bit (36); /* descriptor paramter for pad length entry */ end;  vrmu_delete_indexes.pl1 11/23/84 0800.9r w 11/21/84 0934.1 22581 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ vrmu_delete_indexes: proc (iocb_ptr, key_list_ptr, tuple_id, code); /* NOTES: This procedure deletes all keys in the list pointed to by key_list_ptr from the tuple designated by tuple_id. */ /* HISTORY: Initially written by JA Weeldreyer -- January, 1979. Modified by R. Harvey September 1982 for vfile_relmgr_ */ %page; /* vrmu_delete_indexes: proc (iocb_ptr, key_list_ptr, tuple_id, code); */ /* Parameters */ dcl iocb_ptr ptr; /* vfile iocb */ /* dcl key_list_ptr ptr; /* key values to be deleted */ dcl tuple_id bit (36) aligned; /* record keys were associated with */ dcl code fixed bin (35); /* output error code */ do i = 1 to key_list.number_of_keys; /* delete each key in list */ key_list.key_info.vf_info.input_key (i), /* set up info for vfile */ key_list.key_info.vf_info.input_desc (i) = "1"b; addr (key_list.key_info.vf_info.vf_desc (i)) -> b36 = tuple_id; call iox_$control (iocb_ptr, "delete_key", addr (key_list.key_info.vf_info (i)), icode); /* let vfile do work */ if icode ^= 0 then call error (icode); end; /* deleting keys */ code = 0; exit: return; %page; error: proc (cd); /* Error procedure */ dcl cd fixed bin (35); code = cd; go to exit; end error; %page; %include vrm_key_list; dcl i fixed bin; /* internal index */ dcl b36 bit (36) based; /* template */ dcl icode fixed bin (35); /* internal status code */ dcl addr builtin; dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); end vrmu_delete_indexes;  vrmu_display_descriptor.pl1 11/23/84 0800.9r w 11/21/84 0934.1 91557 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1976 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* HISTORY: Written by Jim Gray - - Dec. 1979, to include new data types in MR7 release of PL1 and replace the old mrds_cmdb_alpha_desc with a more general routine. Modified March 25, 1980 by R. Lackey to remove calls to mdbm_util_ 81-09-23 Davids: changed an if statement with a substr reference to an if statement with an index reference to prevent a stringrange condition from occuring if the requested string is larger than the original string. 82-09-10 Roger Lackey: converted to vrmu_display_descriptor */ vrmu_display_descriptor: procedure (desc_ptr) returns (char (120) varying); /* DESCRIPTION: given a pointer to a multics pl1 standard argument descriptor (see subsystem writers guide for format and data types) this routine returns a character string that includes the pl1 keywords attributes that would have appeared in a declaration that produced the given descriptor, plus some clarifying comments, when no keywords are available to describe the data type. for example: if the input pointer pointed to the descriptor "100000110000000000000000000000010001"b then the output would look like "real fixed binary (17,0) unaligned" for an input of "100100110000000000000000000000010001"b the output would be "real fixed decimal (17,0) unaligned /* leading sign 4-bit byte-aligned * /" structures are only displayed as "structure /* 4 elements * /" an array example would be "character (96) varying aligned dimension(1:20,3:-3)" NOTE: the descriptor/array bounds informations is assumed to be in correct format with legal values, no error checking is done in this routine, since this is to be an efficient run-time routine(cmdb should guarantee correctness). */ /* PARAMETERS: desc_ptr - - (input) pointer, points to a standard multics pl1 argument descriptor(bit(36) aligned), as described in the subsystem writers guide(under argument list format) if not scalar, the array bounds/multiplier follow the descriptor in consecutive fixed bin(35) words. declaration - - (output) char(120) varying, the declaration of the data type varying, as it would appear after a declare statement that would produce the given descriptor, plus clarifying comments. */ /* break down the descriptor into its individual parts */ call decode_descriptor_ (desc_ptr, 0, type, unaligned, ndims, size, scale); /* set up the return declaration according to the descriptor fields */ if type < 1 | type > 63 then declaration = "Unrecognized data type"; else do; /* get the basic data type declaration based on the type */ declaration = data_type (type); if index (declaration, "Unused") = 1 then ; /* CHANGE 81-09-23 ********** */ else do; /* go add data type specific information */ call add_specifics (); /* now add common attribute information, first alignment */ if ^new_format_descriptor then ; /* packing info not available in old descriptor */ else do; if unaligned then declaration = declaration || " unaligned"; else declaration = declaration || " aligned"; end; /* now add dimension info, if any */ if ndims = 0 then ; else do; if ^new_format_descriptor then /* number of dimension unknown in old format */ declaration = declaration || " /* array, old format descriptor */"; else call add_dimension (); end; /* add on clarifying comments */ declaration = declaration || comment (type); end; end; /* report final declaration attributes to caller */ return (declaration); add_specifics: procedure (); /* add precision/scale for numbers, string size for bit/char, or number of elements for a structure */ /* numeric types need a precision, scale field attribute */ if vrmu_data_class$number (desc_ptr) then do; /* arithmetic data types */ declaration = declaration || " ("; declaration = declaration || ltrim (char (size)); if ^vrmu_data_class$fixed (desc_ptr) then ; /* float types don't have scale */ else do; declaration = declaration || ","; declaration = declaration || ltrim (char (scale)); end; declaration = declaration || ")"; end; /* areas, bit, and character types need a size field */ else if type >= 18 & type <= 22 then do; /* area or bit or character */ declaration = declaration || " ("; declaration = declaration || ltrim (char (size)); declaration = declaration || ")"; /* add the varying/nonvarying attribute for bit or character strings */ if type = 20 | type = 22 then declaration = declaration || " varying"; else if type = 19 | type = 21 then declaration = declaration || " nonvarying"; end; /* report via a comment, the number of structure elements */ else if type = 17 then do; /* structure */ if ^new_format_descriptor then ; /* no info on elements in old descriptor */ else do; declaration = declaration || " /* "; declaration = declaration || ltrim (char (size)); declaration = declaration || " element"; if size = 1 then declaration = declaration || " */"; else declaration = declaration || "s */"; end; end; end; add_dimension: procedure (); /* add the dimension attribute, with array bounds */ declaration = declaration || " dimension ("; /* add a bound_pair "upper:lower" for each dimension */ do dimension_number = 1 to ndims; offset = (3 * dimension_number) - 2; /* number of words from descriptor to bound */ /* pick up bounds words following descriptor */ declaration = declaration || ltrim (char (addrel (desc_ptr, offset) -> lower_bound)); declaration = declaration || ":"; declaration = declaration || ltrim (char (addrel (desc_ptr, offset + 1) -> upper_bound)); /* add separator or terminator */ if dimension_number < ndims then declaration = declaration || ","; else declaration = declaration || ")"; end; end; dcl desc_ptr ptr; /* pointer to Multics descriptor (input) */ declare declaration char (120) varying;/* This variable used to build return declaration */ declare type fixed bin; /* descriptor type */ declare unaligned bit (1) aligned; /* indicates unaligned ("1"b) or aligned ("0"b) */ declare ndims fixed bin; /* number dimensions ; must be zero for dbm version 1 */ declare size fixed bin; /* char string size or arithmetic precision */ declare scale fixed bin; /* arithmetic scale factor */ declare data_type (1:63) char (28) varying internal static options (constant) initial ( "real fixed binary", "real fixed binary", "real float binary", "real float binary", /* 1 - 4 */ "complex fixed binary", "complex fixed binary", "complex float binary", "complex float binary", /* 5 - 8 */ "real fixed decimal", "real float decimal", "complex fixed decimal", "complex float decimal", /* 9 - 12 */ "pointer", "offset", "label", "entry", /* 13 - 16 */ "structure", "area", "bit", "bit", /* 17 - 20 */ "character", "character", "file", /* 21 - 23 */ (5) ("Unused data type"), /* 24 - 28 */ (2) ("real fixed decimal"), /* 29 - 30 */ (2) ("Unused data type"), /* 31 - 32 */ (2) ("real unsigned fixed binary"), /* 33 - 34 */ "real unsigned fixed decimal", /* 35 */ "real fixed decimal", /* 36 */ "Unused data type",/* 37 */ "real unsigned fixed decimal", /* 38 */ "real fixed decimal", /* 39 */ "Unused data type",/* 40 */ (2) ("real fixed decimal", "real float decimal"), /* 41 - 44 */ "complex fixed decimal", "complex float decimal", /* 45 - 46 */ (17) ("Unused data type")); /* 47 - 63 */ declare comment (1:63) char (40) varying internal static options (constant) initial ( (8) (""), /* 1 - 8 */ (2) (" /* leading sign 9-bit */", " /* 9-bit */"), /* 9 - 12 */ (16) (""), /* 13 - 28 */ " /* leading overpunched sign 9-bit */", /* 29 */ " /* trailing overpunched sign 9-bit */", /* 30 */ (4) (""), /* 31 - 34 */ " /* 9-bit */", /* 35 */ " /* trailing sign 9-bit */", /* 36 */ "", " /* 4-bit */",/* 37 - 38 */ " /* trailing sign 4-bit */", /* 39 */ "", " /* leading sign 4-bit */", " /* 4-bit */", /* 40 - 42 */ " /* leading sign 4-bit byte-aligned */", /* 43 */ " /* 4-bit byte-aligned */", /* 44 */ " /* leading sign 4-bit byte-aligned */", /* 45 */ " /* 4-bit byte-aligned */", /* 46 */ (17) ("")); /* 47 - 63 */ declare (ltrim, index, addrel, char) builtin; declare decode_descriptor_ entry (ptr, fixed bin, fixed bin, bit (1) aligned, fixed bin, fixed bin, fixed bin); declare new_format_descriptor bit (1) unal based (desc_ptr); /* version bit of descriptor is first */ declare dimension_number fixed bin; /* number of current dimension */ declare offset fixed bin; /* number of words past desc_ptr, to get array bound */ declare (lower_bound, upper_bound) fixed bin (35) based; /* overlays for array bound info */ declare (vrmu_data_class$number, vrmu_data_class$fixed) entry (ptr) returns (bit (1) aligned); /* decides if data in entries class */ end vrmu_display_descriptor;  vrmu_encode_key.pl1 11/23/84 0800.9rew 11/21/84 0920.3 233235 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ vrmu_encode_key: proc (key_source_list_ptr, key, key_bit_len, code); /* NOTES: This procedure encodes one or more source values to form a key. All supported data types (with the exception of complex data) are encoded in such a fashion that order is preserved. This allows for range searching on the resulting index. */ /* HISTORY: Initially written by JA Weeldreyer -- July, 1978. 6-sept-79 Davids: added the output parameter key_bit_len which is the actual number of bits used in the key. 17-oct-79 Davids: Changed dcl of size (length of varying attribute) to unaligned so that it can be based on a pointer that points into the middle of a word. 18-oct-79 Davids: Simplified the encoding of varying strings so that its more like fixed length strings. Also took out the internal byte alignment of character strings within the key string. 28-nov-79 Davids: Modified so that a calculation of the number of bits used by a varying character string is performed rather then relying on the length word of the string having been modified to contain the number of bits rather then the number of characters (which wsa not done in all cases). Of course now the length word better contain the number of chacaters for all cases. Modified by Jim Gray - - Dec. 1979, to add call to mu_data_class$scalar 14-jan-80 Davids: Completely rewrote encoding code for fixed and float decimal unaligned. 14-jan-80 Davids: Changed types 12, 46, and 46 (all complex) so that they merely copy the data across to the key since no encoding is required (only equal and not equal are allowed). Modified by R. Lackey March 25, 1980 to remove calls to mdbm_util_ 81-09-19 Davids: added the based unsigned fixed bin variable fb8 for use when overlaying the exponent sign and value bits in a float binary number, this prevents a size condition from occuring when the source exponent value is 0. 82-09-17 R. Harvey: Renamed and modified for use by vfile_relmgr 84-05-25 B. G. Moberg: Added new entry point, compute_offset_and_length. Although this entry point shares no code with the rest of the routine, it was placed here because attribute lengths and offsets are calculated differently when there are parts of keys then anywhere else. Therefore, it was felt that it would be much more clear if this different calculation was done in only one routine. 84-05-30 B. G. Moberg: Changed the new entry point to also return the alignment as there is a case that needs this. */ /* vrmu_encode_key: proc (key_source_list_ptr, key, key_bit_len, code); */ num_dims, index_value_length = 0; len_ptr = addr (key); /* initialize */ index_ptr = addrel (len_ptr, 1); data_ptr = addr (index.index_value); max_bits = 2277; /* <--------vfile_ keys can be a maximum 256 characters. The first 3 chars of the key are rel_id, index_id, pad (see index structure). That leaves 253 characters of data (or 2277 bits)! (quote from Noah Davids 10/04/83) */ offset = 1; data_str = "0"b; do i = 1 to key_source_list.number_of_values; /* encode each key attr. */ call encode_proc (key_source_list.val_info.val_ptr (i), key_source_list.val_info.desc_ptr (i)); end; /* encoding loop */ index.mbz = "0"b; /* finish the index */ key_length = ceil (divide ((offset - 1), 9, 17, 17)) + 3; /* set key length in chars */ key_bit_len = offset + 26; /* <------offset contains the actual number of bits that make up the encode key + 1. Adding 26 gives a bit length of encoded key + 3 characters. See above comment for max_bits. (ibid) */ code = 0; exit: return; encode_attr: entry (ss_ptr, a_desc_ptr, encd_str, code); /* entry to encode an arbitrary attribute value */ offset = 1; /* initialize */ len_ptr = addr (encd_str); data_ptr = addrel (len_ptr, 1); max_bits = 9 * maxlength (encd_str); data_str = "0"b; call encode_proc (ss_ptr, a_desc_ptr); key_length = ceil (divide ((offset - 1), 9, 17, 17)); code = 0; return; compute_alignment_and_length: entry (ds_ptr, key_offset, key_alignment, key_attr_len); desc_ptr = ds_ptr; ovfl = 0; /* most types need no alignment */ go to compute (descriptor.type); /* go compute this value */ compute (1): /* fixed bin short */ if descriptor.packed then p = fixed (descriptor.size.precision); else p = 35; len = p + 1; go to done; compute (2): /* fixed bin long */ if descriptor.packed then p = fixed (descriptor.size.precision); else p = 71; len = p + 1; go to done; compute (3): /* float bin short */ if descriptor.packed then p = fixed (descriptor.size.precision); else p = 27; len = p + 9; go to done; compute (4): /* float bin long */ if descriptor.packed then p = fixed (descriptor.size.precision); else p = 63; len = p + 9; go to done; compute (5): /* complex fixed bin short */ if descriptor.packed then len = 2 * (fixed (descriptor.size.precision) + 1); else len = 72; go to done; compute (6): /* complex fixed bin long */ if descriptor.packed then len = 2 * (fixed (descriptor.size.precision) + 1); else len = 144; go to done; compute (7): /* complex float bin short */ if descriptor.packed then len = 2 * (fixed (descriptor.size.precision) + 9); else len = 72; go to done; compute (8): /* complex float bin long */ if descriptor.packed then len = 2 * (fixed (descriptor.size.precision) + 9); else len = 144; go to done; compute (9): /* real fixed decimal */ ovfl = mod (key_offset, 9); /* byte align */ p = fixed (descriptor.size.precision); len = 9 * (p + 1); go to done; compute (10): /* real float decimal */ p = fixed (descriptor.size.precision); len = 9 * (p + 2); go to done; compute (11): /* complex fixed decimal */ ovfl = mod (key_offset, 9); len = 18 * (fixed (descriptor.size.precision) + 1); go to done; compute (12): /* complex float decimal */ p = fixed (descriptor.size.precision); len = 18 * (fixed (descriptor.size.precision) + 2); go to done; compute (13): /* unsupported types */ compute (14): compute (15): compute (16): compute (17): compute (18): len = 0; /* This should never happen */ go to done; compute (19): /* bit string */ len = fixed (string (descriptor.size)); go to done; compute (20): /* varying bit string */ len = fixed (string (descriptor.size)) + 36; /* length of attribute (36 for count word) */ go to done; compute (21): /* char. string */ len = 9 * fixed (string (descriptor.size)); go to done; compute (22): /* varying char. string */ len = 9 * fixed (string (descriptor.size)) + 36; /* length (in bits) of attribute (36 for the count word) */ go to done; compute (23): /* unsupported types */ compute (24): compute (25): compute (26): compute (27): compute (28): compute (29): compute (30): compute (31): compute (32): compute (33): compute (34): compute (35): compute (36): compute (37): compute (38): compute (39): compute (40): compute (41): compute (42): len = 0; /* This should never happen */ go to done; compute (43): len = vrmu_data_length (desc_ptr -> descr_ovrly); go to done; compute (44): len = vrmu_data_length (desc_ptr -> descr_ovrly); go to done; compute (45): len = vrmu_data_length (desc_ptr -> descr_ovrly); /* complex float dec unal */ go to done; compute (46): len = vrmu_data_length (desc_ptr -> descr_ovrly); /* complex fixed dec unal */ go to done; done: key_attr_len = len; key_alignment = 0; if ovfl > 0 then key_alignment = 9 - ovfl; return; encode_proc: proc (vp, dp); /* procedure to do the actual encoding */ dcl j fixed bin (35); dcl (vp, dp) ptr; dcl valid_decimal_ entry (fixed bin, ptr, fixed bin) returns (bit (1)); declare vrmu_data_class$scalar entry (ptr) returns (bit (1) aligned); dcl mdbm_error_$invalid_dec_data fixed bin (35) ext; val_ptr = vp; desc_ptr = dp; if ^(vrmu_data_class$scalar (desc_ptr)) then call error (mdbm_error_$unsup_type); go to encode (descriptor.type); /* go encode this value */ encode (1): /* fixed bin short */ if descriptor.packed then p = fixed (descriptor.size.precision); else p = 35; call encode_fxb; go to next; encode (2): /* fixed bin long */ if descriptor.packed then p = fixed (descriptor.size.precision); else p = 71; call encode_fxb; go to next; encode (3): /* float bin short */ if descriptor.packed then p = fixed (descriptor.size.precision); else p = 27; call encode_flb; go to next; encode (4): /* float bin long */ if descriptor.packed then p = fixed (descriptor.size.precision); else p = 63; call encode_flb; go to next; encode (5): /* complex fixed bin short */ if descriptor.packed then len = 2 * (fixed (descriptor.size.precision) + 1); else len = 72; substr (data_str, offset, len) = val_ptr -> bit_str; /* no encoding for complex */ offset = offset + len; go to next; encode (6): /* complex fixed bin long */ if descriptor.packed then len = 2 * (fixed (descriptor.size.precision) + 1); else len = 144; substr (data_str, offset, len) = val_ptr -> bit_str; offset = offset + len; go to next; encode (7): /* complex float bin short */ if descriptor.packed then len = 2 * (fixed (descriptor.size.precision) + 9); else len = 72; substr (data_str, offset, len) = val_ptr -> bit_str; offset = offset + len; go to next; encode (8): /* complex float bin long */ if descriptor.packed then len = 2 * (fixed (descriptor.size.precision) + 9); else len = 144; substr (data_str, offset, len) = val_ptr -> bit_str; offset = offset + len; go to next; encode (9): /* real fixed decimal */ ovfl = mod (offset - 1, 9); /* byte align */ if ovfl > 0 then offset = offset + 9 - ovfl; cp_ptr = addr (data_bits (offset)); /* point to current pos. */ p = fixed (descriptor.size.precision); /* will always pack */ if fxd.sign = "+" then cp_ptr -> fxd.sign = "p"; /* change sign to preserve order */ else cp_ptr -> fxd.sign = "n"; if fxd.sign = "-" then /* if negative no, take 9's compl. */ do j = 1 to p; cp_ptr -> fxd.digit (j) = 9 - fxd.digit (j); end; else do j = 1 to p; /* if positive, just copy digits */ cp_ptr -> fxd.digit (j) = fxd.digit (j); end; offset = offset + 9 * (p + 1); go to next; encode (10): /* real float decimal */ p = fixed (descriptor.size.precision); call encode_fld; offset = offset + 9 * (p + 2); go to next; encode (11): /* complex fixed decimal */ ovfl = mod (offset - 1, 9); if ovfl > 0 then offset = offset + 9 - ovfl; /* byte align */ len = 18 * (fixed (descriptor.size.precision) + 1); substr (data_str, offset, len) = val_ptr -> bit_str; /* no encoding for complex */ offset = offset + len; go to next; encode (12): /* complex float decimal */ p = fixed (descriptor.size.precision); len = 18 * (fixed (descriptor.size.precision) + 2); substr (data_str, offset, len) = val_ptr -> bit_str; offset = offset + len; go to next; encode (13): /* unsupported types */ encode (14): encode (15): encode (16): encode (17): encode (18): call error (mdbm_error_$unsup_type); encode (19): /* bit string */ len = fixed (string (descriptor.size)); substr (data_str, offset, len) = val_ptr -> bit_str; offset = offset + len; go to next; encode (20): /* varying bit string */ len = fixed (string (descriptor.size)) + 36; /* length of attribute (36 for count word) */ substr (data_str, offset, len) = "0"b; sz_ptr = val_ptr; /* point to actual number of bits */ val_ptr = addr (val_ptr -> data_bits (37)); /* point to actual string */ substr (data_str, offset, size) = substr (val_ptr -> bit_str, 1, size); offset = offset + len; go to next; encode (21): /* char. string */ len = 9 * fixed (string (descriptor.size)); substr (data_str, offset, len) = val_ptr -> bit_str; offset = offset + len; go to next; encode (22): /* varying char. string */ len = 9 * fixed (string (descriptor.size)) + 36; /* length (in bits) of attribute (36 for the count word) */ substr (data_str, offset, len) = "0"b; sz_ptr = val_ptr; /* pointer to actual number of characters */ no_bits = size * 9; val_ptr = addr (val_ptr -> data_bits (37)); /* pointer to actual string */ substr (data_str, offset, no_bits) = substr (val_ptr -> bit_str, 1, no_bits); offset = offset + len; go to next; encode (23): /* unsupported types */ encode (24): encode (25): encode (26): encode (27): encode (28): encode (29): encode (30): encode (31): encode (32): encode (33): encode (34): encode (35): encode (36): encode (37): encode (38): encode (39): encode (40): encode (41): encode (42): call error (mdbm_error_$unsup_type); encode (43): call encode_fxd4; /* fixed dec unal */ offset = offset + vrmu_data_length (desc_ptr -> descr_ovrly); go to next; encode (44): call encode_fld4; /* float dec unal */ offset = offset + vrmu_data_length (desc_ptr -> descr_ovrly); go to next; encode (45): len = vrmu_data_length (desc_ptr -> descr_ovrly); /* complex float dec unal */ substr (data_str, offset, len) = val_ptr -> bit_str; offset = offset + len; go to next; encode (46): len = vrmu_data_length (desc_ptr -> descr_ovrly); /* complex fixed dec unal */ substr (data_str, offset, len) = val_ptr -> bit_str; offset = offset + len; go to next; next: if (offset - 1) > max_bits then /* if key has gotten too long */ call error (mdbm_error_$long_key); encode_fxb: proc; /* Procedure to encode fixed bin, merely flips sign bit */ cp_ptr = addr (data_bits (offset)); cp_ptr -> fxb.sign = ^fxb.sign; cp_ptr -> fxb.val = fxb.val; offset = offset + p + 1; end encode_fxb; encode_flb: proc; /* Procedure to encode float bin, merely transforms so that bit sort will order correctly. */ cp_ptr = addr (data_bits (offset)); flb_enc.msign = ^flb_src.msign; flb_enc.mval = flb_src.mval; if flb_src.msign = "1"b then /* if is neg. no */ addr (flb_enc.esign) -> fb8 = 128 - addr (flb_src.esign) -> fb8; /* compl. exp. */ /* CHANGE 81-09-19 */ else do; /* positive, merely flip sign bit */ flb_enc.esign = ^flb_src.esign; flb_enc.eval = flb_src.eval; end; offset = offset + p + 9; end encode_flb; encode_fld: proc; cp_ptr = addr (data_bits (offset)); if ^valid_decimal_ (binary (descriptor.type), val_ptr, binary (descriptor.size.precision)) then call error (mdbm_error_$invalid_dec_data); do j = 1 to p while (fld_src.digit (j) = 0); /* scan for first non-zero digit */ end; if j > p then do; /* have zero value */ fld_enc.msign = "p"; fld_enc.esign, fld_enc.epad, fld_enc.eval = "0"b; do j = 1 to p; fld_enc.digit (j) = 0; end; end; /* if have zero value */ else do; /* for non-zero values */ power_delta = p - j + 1; /* number to add to exponent */ shift_delta = j - 1; /* no. characters to shift */ if addr (fld_src.esign) -> fb7 + power_delta > 127 then /* if will overflow */ call error (mdbm_error_$key_encd_ovfl); addr (fld_enc.esign) -> fb7 = addr (fld_src.esign) -> fb7 + power_delta; fld_enc.epad = "0"b; if fld_src.msign = "-" then do; /* if negative no. */ fld_enc.msign = "n"; do j = 1 to p - shift_delta; /* 9's compl. of signif. digits to front */ fld_enc.digit (j) = 9 - fld_src.digit (j + shift_delta); end; do j = p - shift_delta + 1 to p; /* fill in trailing 9's */ fld_enc.digit (j) = 9; end; addr (fld_enc.esign) -> fb7 = 128 - addr (fld_enc.esign) -> fb7; /* complement exp. so will sort right */ end; /* if negative no. */ else do; /* if positive no. */ fld_enc.msign = "p"; do j = 1 to p - shift_delta; /* move signif. digits to front */ fld_enc.digit (j) = fld_src.digit (j + shift_delta); end; do j = p - shift_delta + 1 to p; /* put in trailing 0's */ fld_enc.digit (j) = 0; end; fld_enc.esign = ^fld_enc.esign; /* flip sign bit so will sort right */ end; /* if positive no. */ end; /* if non-zero */ end encode_fld; %page; /* Encoding algorithm for fixed and float decimal unaligned for a fixed data type just ignore rules about exponent. For negative numbers (sign = "1101"b) 1. set sign to "0000"b 2. copy sign of exponent 3. copy complement of exponent 4. copy complement of number For positive numbers 1. set sign to "1111"b 2. copy number 3. if number is zero a. set exponent to "0000000"b b. set sign of exponet to "0"b 4. if number is not zero a. copy exponent b. copy sign of exponet Note: zero is normally stored as a positive number with the maximum possible exponent. */ encode_fxd4: proc; cp_ptr = addr (data_bits (offset)); p = fixed (descriptor.size.precision); if mod (p, 2) = 1 then do; digit_len = (divide ((p - 1), 2, 17, 0) * 9) + 4; if odd_fxd4_src.sign = "1101"b then do; odd_fxd4_enc.sign = "0000"b; odd_fxd4_enc.digits = ^(odd_fxd4_src.digits); end; else do; odd_fxd4_enc.sign = "1111"b; odd_fxd4_enc.digits = odd_fxd4_src.digits; end; end; else do; digit_len = (divide (p, 2, 17, 0)) * 9; if even_fxd4_src.sign = "1101"b then do; even_fxd4_enc.sign = "0000"b; even_fxd4_enc.digits = ^(even_fxd4_src.digits); end; else do; even_fxd4_enc.sign = "1111"b; even_fxd4_enc.digits = even_fxd4_src.digits; end; end; end encode_fxd4; %page; encode_fld4: proc; cp_ptr = addr (data_bits (offset)); p = fixed (descriptor.size.precision); if mod (p, 2) = 1 then do; digit_len = ((divide ((p - 1), 2, 17, 0)) * 9) + 4; if odd_fld4_src.sign = "1101"b then do; odd_fld4_enc.sign = "0000"b; odd_fld4_enc.esign = odd_fld4_src.exp.sign; odd_fld4_enc.exp = ^(odd_fld4_src.exp.exp); odd_fld4_enc.digits = ^(odd_fld4_src.digits); end; else do; odd_fld4_enc.sign = "1111"b; odd_fld4_enc.digits = odd_fld4_src.digits; if odd_fld4_src.digits = "0"b then do; odd_fld4_enc.esign = "0"b; odd_fld4_enc.exp = "0"b; end; else do; odd_fld4_enc.esign = ^(odd_fld4_src.exp.sign); odd_fld4_enc.exp = odd_fld4_src.exp.exp; end; end; end; else do; digit_len = (divide (p, 2, 17, 0)) * 9; if even_fld4_src.sign = "1101"b then do; even_fld4_enc.sign = "0000"b; even_fld4_enc.esign = even_fld4_src.exp.sign; even_fld4_enc.exp = ^(even_fld4_src.exp.high) || ^(even_fld4_src.exp.low); even_fld4_enc.digits = ^(even_fld4_src.digits); end; else do; even_fld4_enc.sign = "1111"b; even_fld4_enc.digits = even_fld4_src.digits; if even_fld4_src.digits = "0"b then do; even_fld4_enc.esign = "0"b; even_fld4_enc.exp = "0"b; end; else do; even_fld4_enc.esign = ^(even_fld4_src.exp.sign); even_fld4_enc.exp = even_fld4_src.exp.high || even_fld4_src.exp.low; end; end; end; end encode_fld4; end encode_proc; %page; error: proc (cd); /* error procedure */ dcl cd fixed bin (35); code = cd; go to exit; end error; %page; dcl descr_ovrly bit (36) based unal; dcl key char (256) var; /* Output: encoded key */ dcl key_bit_len fixed bin (35); /* Output: number of bits of encoded data in the key */ dcl key_alignment fixed bin (17); /* Output: number of bits to add to offset to align */ dcl key_attr_len fixed bin (17); /* Output: number of bits of encoded data in key attribute */ dcl key_offset fixed bin (17); /* Input: Current offset in key - zero based */ dcl ds_ptr ptr; /* Input: pointer to descriptor */ dcl code fixed bin (35); /* Output: status code */ dcl max_bits fixed bin (35); /* max bits allowed in encoded string */ dcl (len_ptr, /* pointer to length field of key */ val_ptr, /* ptr to a source value */ data_ptr, /* pointer to bit view of key */ cp_ptr, /* pointer to current position in key */ ss_ptr, /* Input: to attr. string to be encoded */ a_desc_ptr, /* Input: to descriptor of input value */ sz_ptr) ptr; /* ptr to length field of varying value */ dcl (i, /* internal index */ ovfl, /* no. overflow bits for aligning */ offset, /* current bit position in key */ p, /* precision of value */ len /* bit length of value */ ) fixed bin; dcl data_str bit (max_bits) unal based (data_ptr); /* bit string view of key */ dcl data_bits (max_bits) bit (1) unal based (data_ptr); /* bit array view */ dcl key_length fixed bin (35) based (len_ptr); /* char. length of key */ dcl encd_str char (*) var; /* Output: encoded attr. value */ dcl bit_str bit (len) based; /* template */ dcl (power_delta, /* increase in exp. for normaliz. */ shift_delta) fixed bin (7); /* no chars to shift for norm. */ dcl fb7 fixed bin (7) based unal; /* template */ dcl fb8 fixed bin (8) based unal unsigned; /* template */ dcl size fixed bin (35) unaligned based (sz_ptr); /* curr. len. of varying value */ dcl no_bits fixed bin (35) unaligned; /* number of bits in vary char attr. */ dcl 1 fxb unal based (val_ptr), /* fixed bin template */ 2 sign bit (1) unal, 2 val bit (p) unal; dcl 1 flb_src unal based (val_ptr), /* template for source float bin */ 2 esign bit (1) unal, 2 eval bit (7) unal, 2 msign bit (1) unal, 2 mval bit (p) unal; dcl 1 flb_enc unal based (cp_ptr), /* template for encoded float bin */ 2 msign bit (1) unal, 2 esign bit (1) unal, 2 eval bit (7) unal, 2 mval bit (p) unal; dcl 1 fxd unal based (val_ptr), /* template for fixed dec. */ 2 sign char (1) unal, 2 digit (p) pic "9" unal; dcl 1 fld_src unal based (val_ptr), /* template for float dec source */ 2 msign char (1) unal, 2 digit (p) pic "9" unal, 2 epad bit (1) unal, 2 esign bit (1) unal, 2 eval bit (7) unal; dcl 1 fld_enc unal based (cp_ptr), /* template for float dec encoded */ 2 msign char (1) unal, 2 epad bit (1) unal, 2 esign bit (1) unal, 2 eval bit (7) unal, 2 digit (p) pic "9" unal; dcl 01 odd_fxd4_src based (val_ptr), 02 pad1 bit (1) unal, 02 sign bit (4) unal, 02 digits bit (digit_len) unal; dcl 01 even_fxd4_src based (val_ptr), 02 pad1 bit (1) unal, 02 sign bit (4) unal, 02 digits bit (digit_len) unal, 02 pad2 bit (4) unal; dcl 01 odd_fxd4_enc based (cp_ptr), 02 pad1 bit (1) unal init ("0"b), 02 sign bit (4) unal, 02 digits bit (digit_len) unal; dcl 01 even_fxd4_enc based (cp_ptr), 02 pad1 bit (1) unal init ("0"b), 02 pad2 bit (4) unal init ("0"b), 02 sign bit (4) unal, 02 digits bit (digit_len) unal; dcl 01 even_fld4_src based (val_ptr), 02 pad1 bit (1) unal, 02 sign bit (4) unal, 02 digits bit (digit_len) unal, 02 exp, 03 sign bit (1) unal, 03 high bit (3) unal, 03 pad2 bit (1) unal, 03 low bit (4) unal, 03 pad3 bit (4) unal; dcl 01 odd_fld4_src based (val_ptr), 02 pad1 bit (1) unal, 02 sign bit (4) unal, 02 digits bit (digit_len) unal, 02 exp, 03 pad2 bit (1) unal, 03 sign bit (1) unal, 03 exp bit (7) unal; dcl 01 odd_fld4_enc based (cp_ptr), 02 pad1 bit (1) unal init ("0"b), 02 pad2 bit (1) unal init ("0"b), 02 sign bit (4) unal, 02 esign bit (1) unal, 02 exp bit (7) unal, 02 digits bit (digit_len) unal; dcl 01 even_fld4_enc based (cp_ptr), 02 pad1 bit (1) unal init ("0"b), 02 pad2 bit (1) unal init ("0"b), 02 pad3 bit (4) unal init ("0"b), 02 sign bit (4) unal, 02 esign bit (1) unal, 02 exp bit (7) unal, 02 digits bit (digit_len) unal; dcl digit_len fixed bin; dcl (mdbm_error_$unsup_type, mdbm_error_$long_key, mdbm_error_$key_encd_ovfl) fixed bin (35) ext; dcl (addr, addrel, binary, divide, fixed, substr, mod, string, maxlength, ceil) builtin; dcl vrmu_data_length entry (bit (36)) returns (fixed bin (35)); %page; %include mdbm_descriptor; %include vrm_index; %include vrm_key_source_list; end vrmu_encode_key;  vrmu_init_rel_desc.pl1 10/16/86 1626.5r w 10/16/86 1143.7 139545 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ vrmu_init_rel_desc: proc (I_db_path, I_rel_name, I_uid, I_model_ptr, I_vrm_com_ptr, I_oid, O_vrm_open_info_ptr, O_code); /* BEGIN_DESCRIPTION The purpose of this procedure is to create and initialize the vrm_rel_desc for a given relation. END_DESCRIPTION */ /* HISTORY 82-08-17 Written by Roger Lackey 82-11-02 Modified by R. Harvey for opening_info/rel_desc structure split 82-11-17 Modified by Roger Lackey : to calculate the pri_key_offset for varying strings like encode_key does 82-12-09 Modified by Roger Lackey : To added vrm_iocb_list_block handling 82-12-20 Modified by Roger Lackey : To add initiate the vfile_ component that contains the vrm_rel_desc for an internal model so the vfile opening could be destroy in this program. This allows vrm_open_info.relation_model_ptr valid. 83-05-26 Modified by Roger Lackey : Added vrm_attr_info.key_head bit and vrm_attr_info.primary_key_attr bit 83-06-14 Modified by Ron Harvey : Changed the substr for the file_id field so that it doesn't pick up the last 7 bits, but instead acts like MR 10.0 and previous MRDS code. 83-10-03 Modified by Roger Lackey : to put the key_bit_len in vrm_collection_info 84-05-25 Modified by Bert Moberg : to use vrmu_encode_key$compute_offset_and_length so that key lengths are properly calculated 84-05-30 Modified by Bert Moberg : Changed new call to use vrmu_encode_key$compute_alignment_and_length because there was a case that was not being handled properly */ /* PARAMETERS */ dcl I_db_path char (*) parameter;/* Absolute database path */ dcl I_rel_name char (*) parameter;/* Relation name */ dcl I_uid bit (36) aligned parameter; /* uid of relation */ dcl I_model_ptr ptr parameter; /* Pointer to relation model */ dcl I_vrm_com_ptr pointer parameter; /* Pointer to segment where vrm_rel_desc is to be allocated */ dcl I_oid bit (36) aligned parameter; /* Opening id associdated with this desc */ dcl O_vrm_open_info_ptr pointer parameter; /* Pointer to the opening info structure */ dcl O_code fixed bin (35) parameter; /* Error code */ %page; O_vrm_open_info_ptr = null; O_code = 0; vrm_com_ptr = I_vrm_com_ptr; rel_name = I_rel_name; fm_ptr = I_model_ptr; vrm_open_info_ptr = null; vrm_rel_desc_ptr = null; vrm_iocb_list_block_ptr = null; iocb_ptr = null; on cleanup call tidy_up; if fm_ptr ^= null then call build_from_MRDS_model; else call build_from_internal_model; O_vrm_open_info_ptr = vrm_open_info_ptr; exit: return; %page; build_from_MRDS_model: proc; call hcs_$initiate (I_db_path, "db_model", "", 0, 0, dbm_ptr, code); if dbm_ptr = null then call error (error_table_$noentry); ri_ptr = pointer (fm_ptr, file_model.rel_ptr); /* In order to create the opening info structure, we must know the number of index collections (secondary indexes + primary key) */ voi_no_of_index_collections = 0; do i = 1 to rel_info.num_attr; if i = 1 then ai_ptr = pointer (fm_ptr, rel_info.attr_ptr); else ai_ptr = pointer (fm_ptr, attr_info.fwd_thread); if attr_info.index_attr & attr_info.index_id ^= "0"b then voi_no_of_index_collections = voi_no_of_index_collections + 1; end; call create_open_info (voi_no_of_index_collections); /* We'll build the collection info later while walking attribute chain again */ vrd_no_of_attrs = rel_info.num_attr; allocate vrm_rel_desc in (wa) set (vrm_rel_desc_ptr); unspec (vrm_rel_desc) = "0"b; /* Init every thing to zeros */ vrm_open_info.relation_model_ptr = vrm_rel_desc_ptr; vrm_rel_desc.version = VRM_REL_DESC_VERSION_1; vrm_rel_desc.switches.stationary_records = "0"b; /* Will get changed if varing attr is found */ vrm_rel_desc.switches.indexed = rel_info.indexed; vrm_rel_desc.switches.pad = "0"b; vrm_rel_desc.version = VRM_REL_DESC_VERSION_1; fi_ptr = pointer (dbm_ptr, db_model.file_ptr); found = "0"b; do while (^found & rel (fi_ptr) ^= NULL_OFFSET); if file_info.file_name = rel_name then do; found = "1"b; /* Pick up the file_id from the last seven but two bits of the field. This is due to a stringrange bug in previous implementations of MRDS. It is almost certain that the value we pick up is guaranteed to be ZEROS. */ vrm_rel_desc.file_id = substr (file_info.file_id, 28, 7); end; fi_ptr = pointer (dbm_ptr, file_info.fwd_ptr); end; if ^found then call error (error_table_$noentry); vrm_rel_desc.rel_id = substr (rel_info.id, 1, 12); vrm_rel_desc.switches.MRDS_compatible = "1"b; vrm_rel_desc.var_offset = rel_info.var_offset; vrm_rel_desc.maximum_data_length = divide (rel_info.max_data_len, 9, 21, 0); /* convert from bit count to char count */ if mod (rel_info.max_data_len, 9) ^= 0 then vrm_rel_desc.maximum_data_length = vrm_rel_desc.maximum_data_length + 1; vrm_rel_desc.number_primary_key_attrs = rel_info.num_key_attrs; vrm_rel_desc.number_sec_indexes = 0; /* Calculated during walk through attrs */ vrm_rel_desc.last_var_attr_no = 0; /* Calculated during walk through attrs */ vrm_rel_desc.number_var_attrs = rel_info.nvar_atts; vrm_rel_desc.number_attrs = vrd_no_of_attrs; %page; pri_key_offset = 0; /* Offset within primary key in chars */ key_attr_index = 1; /* index for key_attrs substructure */ vci_no_of_attributes = rel_info.num_key_attrs; allocate vrm_collection_info in (wa) set (key_collection_info_ptr); key_collection_info_ptr -> vrm_collection_info.unique = "1"b; key_collection_info_ptr -> vrm_collection_info.primary_key = "1"b; key_collection_info_ptr -> vrm_collection_info.id = "0"b; key_coll_index = 1; vrm_open_info.primary_key_info_ptr = key_collection_info_ptr; open_info_coll_index = 1; /* set for first secondary index */ do i = 1 to vrm_rel_desc.number_attrs; if i = 1 then ai_ptr = pointer (fm_ptr, rel_info.attr_ptr); else ai_ptr = pointer (fm_ptr, attr_info.fwd_thread); di_ptr = pointer (dbm_ptr, attr_info.domain_ptr); desc_ptr = addr (domain_info.db_desc); if descriptor.type = 20 | descriptor.type = 22 /* Bit varying or char varying */ then vrm_rel_desc.switches.stationary_records = "1"b; vrm_rel_desc.attr (i).name = attr_info.name; vrm_rel_desc.attr (i).descriptor = domain_info.db_desc; desc_ptr = addr (domain_info.db_desc); if descriptor.type = 20 | descriptor.type = 22 /* varying bit string or varying character string */ then do; vrm_rel_desc.attr (i).varying = "1"b; vrm_rel_desc.last_var_attr_no = i; end; else vrm_rel_desc.attr (i).varying = "0"b; vrm_rel_desc.attr (i).key_head = "0"b; vrm_rel_desc.attr (i).primary_key_attr = "0"b; if attr_info.key_attr then do; vrm_rel_desc.attr (i).primary_key_attr = "1"b; if pri_key_offset = 0 then vrm_rel_desc.attr (i).key_head = "1"b; call vrmu_encode_key$compute_alignment_and_length (desc_ptr, pri_key_offset, pri_key_align, pri_key_bit_len); pri_key_offset = pri_key_offset + pri_key_align; vrm_collection_info_ptr = key_collection_info_ptr; vrm_collection_info.attribute (key_coll_index).attr_index = i; vrm_collection_info.attribute (key_coll_index).key_offset = pri_key_offset; vrm_collection_info.attribute (key_coll_index).key_bit_len = pri_key_bit_len; pri_key_offset = pri_key_offset + pri_key_bit_len; key_coll_index = key_coll_index + 1; end; if attr_info.index_attr & attr_info.index_id ^= "0"b then do; vrm_rel_desc.attr (i).key_head = "1"b; vrm_rel_desc.number_sec_indexes = vrm_rel_desc.number_sec_indexes + 1; vci_no_of_attributes = 1; allocate vrm_collection_info in (wa) set (vrm_collection_info_ptr); vrm_open_info.index_collection (open_info_coll_index).info_ptr = vrm_collection_info_ptr; vrm_open_info.index_collection (open_info_coll_index).id = substr (attr_info.index_id, 1, 8); vrm_collection_info.id = substr (attr_info.index_id, 1, 8); vrm_collection_info.unique = "0"b; vrm_collection_info.primary_key = "0"b; vrm_collection_info.attribute (1).attr_index = i; vrm_collection_info.attribute (1).key_offset = 0; dummy_offset = 0; /* offset not needed for secondary indexes */ call vrmu_encode_key$compute_alignment_and_length (desc_ptr, dummy_offset, dummy_align, vrm_collection_info.attribute (1).key_bit_len); open_info_coll_index = open_info_coll_index + 1; end; vrm_rel_desc.attr (i).pad = "0"b; vrm_rel_desc.attr (i).bit_length = attr_info.bit_length; vrm_rel_desc.attr (i).bit_offset = attr_info.bit_offset; end; end build_from_MRDS_model; %page; build_from_internal_model: proc; /* Now we must find the internal relation description (if there is one) */ call vrmu_iocb_manager$create_iocb (I_db_path, I_rel_name, KSQR, "1"b, "vrm_open", iocb_ptr, code); if code ^= 0 then call error (code); call iox_$seek_key (iocb_ptr, VRM_REL_DESC_KEY, (0), code); if code = 0 then call iox_$control (iocb_ptr, "record_status", addr (rs_info), code); if code ^= 0 then call error (code); /* rs_info.record_ptr is the pointer to vrm_rel_desc which is a record inf vfile */ /* Make sure the segment that contains the vrm_rel_desc is initiated so we can use the pointer to it */ call hcs_$fs_get_path_name (rs_info.record_ptr, dir, dir_len, ent, code); if code ^= 0 then call error (code); call hcs_$initiate (dir, ent, "", 0, 0, seg_ptr, code); if seg_ptr = null then call error (code); call create_open_info (rs_info.record_ptr -> vrm_rel_desc.number_sec_indexes); vrm_open_info.relation_model_ptr = rs_info.record_ptr; /* Now destroy the iocb used to get the vrm_rel_desc */ call vrmu_iocb_manager$destroy_iocb (iocb_ptr, code); if code ^= 0 then call error (code); end build_from_internal_model; %page; create_open_info: proc (no_of_indexes); dcl no_of_indexes fixed bin parameter; voi_no_of_index_collections = no_of_indexes; allocate vrm_open_info in (wa) set (vrm_open_info_ptr); vrm_open_info.version = VRM_OPEN_INFO_VERSION_1; vrm_open_info.opening_id = I_oid; vrm_open_info.file_uid = I_uid; vrm_open_info.number_of_openings = 1; vrm_open_info.switches.shared = "0"b; vrm_open_info.database_dir_path = I_db_path; vrm_open_info.relation_name = rel_name; vrm_open_info.relation_model_ptr = null (); /* for now */ vrm_open_info.com_ptr = I_vrm_com_ptr; /* Allocate first vrm_list_iocb_block and set its pointer in vrm_open_info */ allocate vrm_iocb_list_block in (wa) set (vrm_iocb_list_block_ptr); vrm_iocb_list_block.num_iocbs_used = 0; vrm_iocb_list_block.prev_block_ptr = null; vrm_iocb_list_block.next_block_ptr = null; vrm_iocb_list_block.iocbs = null; /* Init all to null */ vrm_open_info.iocb_list_ptr = vrm_iocb_list_block_ptr; /* Initialize the collections */ do i = 1 to vrm_open_info.number_of_index_collections; vrm_open_info.index_collection (i).id = "0"b; vrm_open_info.index_collection (i).info_ptr = null (); end; end create_open_info; %page; error: proc (cd); dcl cd fixed bin (35) parameter; O_code = cd; goto exit; end error; tidy_up: proc; if vrm_iocb_list_block_ptr ^= null then free vrm_iocb_list_block; if vrm_rel_desc_ptr ^= null then free vrm_rel_desc; if iocb_ptr ^= null then call vrmu_iocb_manager$destroy_iocb (iocb_ptr, code); end tidy_up; %page; %include vrm_open_info; %page; %include vrm_rel_desc; %page; %include vrm_collection_info; %page; %include vrm_com; %page; %include vrm_iocb_list_block; %page; %include mdbm_db_model; %page; %include mdbm_file_model; %page; dcl desc_ptr ptr; dcl 1 descriptor based (desc_ptr), 2 version bit (1) unal, 2 type fixed bin (6) unsigned unal, 2 packed bit (1) unal, 2 number_dims bit (4) unal, 2 size fixed bin (24) unsigned unal; %page; /* Automatic */ dcl code fixed bin (35); dcl dir char (168); dcl dir_len fixed bin; dcl dummy_align fixed bin; dcl dummy_offset fixed bin; dcl ent char (32); dcl found bit (1); dcl i fixed bin; dcl iocb_ptr ptr; dcl key_attr_index fixed bin; dcl key_collection_info_ptr ptr; dcl key_coll_index fixed bin; dcl open_info_coll_index fixed bin; dcl pri_key_align fixed bin; dcl pri_key_bit_len fixed bin; dcl pri_key_offset fixed bin; dcl rel_name char (30); dcl seg_ptr ptr; /* Based */ dcl wa area (sys_info$max_seg_size) based (vrm_com.work_area_ptr); /* Builtin */ dcl ( addr, divide, fixed, mod, null, pointer, rel, substr ) builtin; /* Condition */ dcl cleanup condition; /* External entries */ dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl iox_$seek_key entry (ptr, char (256) var, fixed bin (21), fixed bin (35)); dcl vrmu_encode_key$compute_alignment_and_length entry (ptr, fixed bin, fixed bin, fixed bin); dcl vrmu_iocb_manager$create_iocb entry (char (*), char (*), fixed bin, bit (1) aligned, char (*), ptr, fixed bin (35)); dcl vrmu_iocb_manager$destroy_iocb entry (ptr, fixed bin (35)); /* External static */ dcl (error_table_$noentry, sys_info$max_seg_size) ext static fixed bin (35); dcl vrm_data_$iocb_list_block_size ext static fixed bin; /* Internal static */ dcl KSQR fixed bin int static options (constant) init (8); dcl NULL_OFFSET bit (18) int static options (constant) init ((18)"1"b); /* Structure */ dcl 1 rs_info aligned, 2 version fixed bin init (2), 2 flags aligned, 3 lock_sw bit (1) unal init ("0"b), 3 unlock_sw bit (1) unal init ("0"b), 3 create_sw bit (1) unal init ("0"b), 3 locate_sw bit (1) unal init ("0"b), 3 inc_ref_count bit (1) unal init ("0"b), 3 dec_ref_count bit (1) unal init ("0"b), 3 locate_pos_sw bit (1) unal init ("0"b), 3 mbz bit (29) unal init ("0"b), 2 record_length fixed bin (21) init (0), 2 max_rec_len fixed bin (21) init (0), 2 record_ptr ptr init (null), 2 descriptor fixed bin (35) init (0), 2 ref_count fixed bin (34) init (0), 2 time_last_modified fixed bin (71) init (0), 2 modifier fixed bin (35) init (0), 2 block_ptr ptr unal init (null), 2 mbz2 (2) fixed bin init (0, 0); dcl 1 sh_info aligned, 2 relation_type fixed bin init (1),/* greater than or equal to */ 2 n fixed bin init (4),/* number of relevant chars in key */ 2 search_key char (4); end vrmu_init_rel_desc;  vrmu_iocb_manager.pl1 11/23/84 0800.9rew 11/21/84 0920.3 108225 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ vrmu_iocb_manager: proc (); return; /* . BEGIN_DESCRIPTION This module provides a common location for creating and destroying iocbs in the vfile_relmgr_ programs. Also manages the list of vrm_iocb_list_block where cursor iocbs are kept. There are 5 entry points: create_iocb for non-cursor use. destroy_iocb for non-cursor use. add_cursor_iocb destroy_cursor_iocb destroy_all_iocbs_for_oid . END_DESCRIPTION */ /* History 82-11-16 R. Harvey: Initially written 82-12-09 Modified by Roger Lackey : To added vrm_iocb_list_block handling 83-06-21 Roger Lackey : Make sure that there is room for two iocb_ptrs in vrm_iocb_list_block, the cursor iocb_ptr and the secondary_iocb_ptr. 83-10-04 Roger Lackey : added the initiazation of quit_signaled = "0"b and to free last block in list in destroy_all_iocb_for_oid 84-10-22 Thanh Nguyen : Added looping three more times to open a relation in case of the heavy loaded system, and the relation is busy in the subroutine attach_and_open. */ %page; create_iocb: entry (I_rel_dir, I_rel_name, I_open_mode, I_stationary, I_caller_name, O_iocb_ptr, O_code); /* This is for non-cursor type iocbs */ dcl I_rel_dir char (*) parameter; dcl I_rel_name char (*) parameter; dcl I_open_mode fixed bin parameter; dcl I_stationary bit (1) aligned parameter; dcl I_caller_name char (*) parameter; dcl O_iocb_ptr ptr parameter; dcl O_code fixed bin (35) parameter; atd = "vfile_ "; atd = atd || rtrim (I_rel_dir); atd = atd || ">"; atd = atd || rtrim (I_rel_name); atd = atd || " -dup_ok -share "; atd = atd || ltrim (char (vrm_data_$max_vfile_wait_time)); if I_stationary then atd = atd || " -stationary"; attach_desc = atd; call attach_and_open (I_caller_name, attach_desc, I_open_mode, O_iocb_ptr, O_code); return; %page; destroy_iocb: entry (I_di_iocb_ptr, O_code); dcl I_di_iocb_ptr ptr parameter; /* dcl O_code fixed bin (35) parameter; error code declared else where */ call delete_iocb (I_di_iocb_ptr, code); /* Call internal proc to do the work */ O_code = code; return; %page; /* * * * * * * * * * * * add_cursor_iocb * * * * * * * * * * * * */ add_cursor_iocb: entry (I_ac_cursor_ptr, O_code); /* This entry point creates and opens an iocb and adds it to the list of iocbs for a specific open_id */ dcl I_ac_cursor_ptr ptr parameter; /* Pointer to vrm_cursor */ /* dcl O_code fixed bin (35) parameter; error code declared else where */ vrm_cursor_ptr = I_ac_cursor_ptr; vrm_rel_desc_ptr = vrm_cursor.vrm_relation_desc_ptr; vrm_open_info_ptr = vrm_cursor.open_info_ptr; vrm_iocb_list_block_ptr = vrm_open_info.iocb_list_ptr; do while (vrm_iocb_list_block.next_block_ptr ^= null); vrm_iocb_list_block_ptr = vrm_iocb_list_block.next_block_ptr; end; /* We must make room for two iocbs_ptrs the cursor_iocb and the secondary_iocb_ptr This procedure only attaches and opens the cursor iocb, the secondary_iocb_ptr is set to null here and is attached and opened when needed by vrmu_search */ if vrm_iocb_list_block.num_iocbs_used + 2 > vrm_data_$iocb_list_block_size then do; save_vrm_iocb_list_block_ptr = vrm_iocb_list_block_ptr; vrm_com_ptr = vrm_open_info.com_ptr; allocate vrm_iocb_list_block in (vrm_com.oid_area) set (vrm_iocb_list_block_ptr); quit_signaled = "0"b; on quit quit_signaled = "1"b; vrm_iocb_list_block.num_iocbs_used = 0; vrm_iocb_list_block.prev_block_ptr = save_vrm_iocb_list_block_ptr; vrm_iocb_list_block.next_block_ptr = null; vrm_iocb_list_block.iocbs = null; /* Init all to null */ save_vrm_iocb_list_block_ptr -> vrm_iocb_list_block.next_block_ptr = vrm_iocb_list_block_ptr; revert quit; if quit_signaled then signal quit; end; atd = "vfile_ "; atd = atd || rtrim (vrm_open_info.database_dir_path); atd = atd || ">"; atd = atd || rtrim (vrm_open_info.relation_name); atd = atd || " -dup_ok -share "; atd = atd || ltrim (char (vrm_data_$max_vfile_wait_time)); if vrm_rel_desc.switches.stationary_records then atd = atd || " -stationary"; attach_desc = atd; picture_opening_id = binary (vrm_cursor.opening_id); open_mode = KSQU; /* Try KSQU first */ call attach_and_open (".file_" || picture_opening_id, attach_desc, open_mode, iocb_ptr, code); if code = 0 then do; vrm_iocb_list_block.num_iocbs_used = vrm_iocb_list_block.num_iocbs_used + 1; vrm_iocb_list_block.iocbs (vrm_iocb_list_block.num_iocbs_used) = iocb_ptr; vrm_cursor.iocb_ptr = iocb_ptr; vrm_cursor.vrm_iocb_list_block_ptr = vrm_iocb_list_block_ptr; vrm_cursor.vrm_iocb_list_block_iocbs_ix = vrm_iocb_list_block.num_iocbs_used; vrm_iocb_list_block.num_iocbs_used = /* Because the secondatry_iocb_ptr goes in this slot */ vrm_iocb_list_block.num_iocbs_used + 1; vrm_cursor.opening_mode = open_mode; end; O_code = code; return; %page; /* * * * * * * * * * * * * * destroy_cursor_iocb * * * * * * * * * * * * */ destroy_cursor_iocb: entry (I_dc_cursor_ptr, O_code); /* This entry point will destroy the iocbs associated with a particular cursor */ /* HISTORY: 83-06-21 Roger Lackey added code to destroy the secondary iocb_ptr */ dcl I_dc_cursor_ptr ptr parameter; /* Pointer to vrm_cursor */ /* dcl O_code fixed bin (35) parameter; error code declared else where */ code = 0; vrm_cursor_ptr = I_dc_cursor_ptr; vrm_iocb_list_block_ptr = vrm_cursor.vrm_iocb_list_block_ptr; if vrm_iocb_list_block.iocbs (vrm_cursor.vrm_iocb_list_block_iocbs_ix + 1) ^= null then /* If vrm_cursor.secondary_iocb_ptr exists */ call delete_iocb (vrm_iocb_list_block.iocbs (vrm_cursor.vrm_iocb_list_block_iocbs_ix + 1), code); vrm_iocb_list_block.iocbs (vrm_cursor.vrm_iocb_list_block_iocbs_ix + 1) = null; vrm_cursor.secondary_iocb_ptr = null; if vrm_iocb_list_block.iocbs (vrm_cursor.vrm_iocb_list_block_iocbs_ix) ^= null then call delete_iocb (vrm_iocb_list_block.iocbs (vrm_cursor.vrm_iocb_list_block_iocbs_ix), code); vrm_iocb_list_block.iocbs (vrm_cursor.vrm_iocb_list_block_iocbs_ix) = null; vrm_cursor.iocb_ptr = null; vrm_cursor.vrm_iocb_list_block_ptr = null; vrm_cursor.vrm_iocb_list_block_iocbs_ix = 0; O_code = code; return; /* Return from destroy_cursor_iocb */ %page; /* * * * * * * * * * * * * * destroy_all_iocbs_for_oid * * * * * * * * */ destroy_all_iocbs_for_oid: entry (I_open_info_ptr, O_code); /* The purpose of this entry is to destroy all the iocbs for a given opening_id */ dcl I_open_info_ptr ptr parameter; /* dcl O_code fixed bin (35) parameter; Defined else where */ vrm_open_info_ptr = I_open_info_ptr; O_code = 0; if vrm_open_info.iocb_list_ptr = null then return;/* Nothing to do */ vrm_iocb_list_block_ptr = vrm_open_info.iocb_list_ptr; do while (vrm_iocb_list_block.next_block_ptr ^= null); /* Find last block */ vrm_iocb_list_block_ptr = vrm_iocb_list_block.next_block_ptr; end; code = 0; delete_loop: do i = 1 to vrm_iocb_list_block.num_iocbs_used while (code = 0); if vrm_iocb_list_block.iocbs (i) ^= null then call delete_iocb (vrm_iocb_list_block.iocbs (i), code); vrm_iocb_list_block.iocbs (i) = null; end; if code = 0 & vrm_iocb_list_block.prev_block_ptr ^= null then do; save_vrm_iocb_list_block_ptr = vrm_iocb_list_block_ptr; vrm_iocb_list_block_ptr = save_vrm_iocb_list_block_ptr -> vrm_iocb_list_block.prev_block_ptr; vrm_iocb_list_block.next_block_ptr = null; quit_signaled = "0"b; on quit quit_signaled = "1"b; free save_vrm_iocb_list_block_ptr -> vrm_iocb_list_block; revert quit; if quit_signaled then signal quit; goto delete_loop; end; else do; /* Last block (first in list) */ quit_signaled = "0"b; on quit quit_signaled = "1"b; free vrm_iocb_list_block_ptr -> vrm_iocb_list_block; vrm_open_info.iocb_list_ptr = null; revert quit; if quit_signaled then signal quit; end; O_code = code; return; /* return from destroy_all_iocbs_for_oid */ %page; /* * * * * * * * * * * * * * * * * attach_and_open * * * * * * * * * * * */ attach_and_open: procedure (I_ao_caller_name, I_attach_desc, I_ao_open_mode, O_ao_iocb_ptr, O_ao_code); dcl O_ao_code fixed bin (35) parameter; dcl O_ao_iocb_ptr ptr parameter; dcl I_ao_caller_name char (*) parameter; dcl I_ao_open_mode fixed bin parameter; dcl I_attach_desc char (*) parameter; dcl count fixed bin (17); /* attach and open the data vfile, filling in the iocb pointer */ call iox_$attach_name (unique_chars_ ("0"b) || I_ao_caller_name, O_ao_iocb_ptr, rtrim (I_attach_desc), null (), code); if code ^= 0 then do; O_ao_iocb_ptr = null (); O_ao_code = code; end; else do; open_mode = I_ao_open_mode; call iox_$open (O_ao_iocb_ptr, open_mode, "0"b, code); if code = error_table_$moderr & open_mode = KSQU /* if not access to open with KSQU */ then do; /* try with just KSQR */ open_mode = KSQR; /* reduce mode and try again */ call iox_$open (O_ao_iocb_ptr, open_mode, "0"b, code); end; /* Just in case the relation is busy by other process. */ do count = 1 to 3 while (code = error_table_$file_busy); call iox_$open (O_ao_iocb_ptr, open_mode, "0"b, code); end; if code = 0 then call iox_$position (O_ao_iocb_ptr, -1, /* Init position to BOF */ 0, code); if code ^= 0 then do; O_ao_code = code; end; else O_ao_code = 0; end; return; end attach_and_open; %page; /* * * * * * * * * * * * delete_iocb * * * * * * * * * * * * * * * */ delete_iocb: proc (I_d_iocb_ptr, O_d_i_code); dcl I_d_iocb_ptr ptr parameter; dcl O_d_i_code fixed bin (35) parameter; call iox_$close (I_d_iocb_ptr, O_d_i_code); if O_d_i_code = 0 then do; call iox_$detach_iocb (I_d_iocb_ptr, O_d_i_code); if O_d_i_code = 0 then call iox_$destroy_iocb (I_d_iocb_ptr, O_d_i_code); end; end delete_iocb; %page; %include vrm_iocb_list_block; %page; %include vrm_cursor; %page; %include vrm_rel_desc; %page; %include vrm_open_info; %page; %include vrm_com; %page; /* Automatic */ dcl atd char (344) varying; dcl attach_desc char (344); dcl code fixed bin (35); dcl save_vrm_iocb_list_block_ptr ptr; dcl i fixed bin (24); dcl iocb_ptr ptr; dcl open_mode fixed bin; dcl picture_opening_id pic "99999"; dcl quit_signaled bit (1); /* Conditions */ dcl quit condition; /* Builtin */ dcl (binary, char, ltrim, null, rtrim) builtin; /* External entry */ dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl iox_$destroy_iocb entry (ptr, fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)); dcl iox_$position entry (ptr, fixed bin, fixed bin (21), fixed bin (35)); dcl unique_chars_ entry (bit (*)) returns (char (15)); /* External static */ dcl (error_table_$file_busy, error_table_$moderr, sys_info$max_seg_size, vrm_data_$max_vfile_wait_time ) fixed bin (35) ext static; dcl vrm_data_$iocb_list_block_size ext static fixed bin; /* Internal static */ dcl KSQR fixed bin int static init (8) options (constant); dcl KSQU fixed bin int static init (10) options (constant); end vrmu_iocb_manager;  vrmu_scan_records.pl1 11/23/84 0800.9r w 11/21/84 0934.1 85464 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ vrmu_scan_records: proc; return; /* BEGIN_DESCRIPTION This routine starts with an indexed vfile_ and returns successive records by reading the record components sequentially. This means the order of returned records has no correspondence to the key order in general. For MRDS needed to have it work with the current vfile_ opening, so needed a variable from the indx_cb. Used transaction_code because it is the correct dcl and is now unused. Should use a variable of its own and this code should be incoorperated into vfile_. END_DESCRIPTION */ /* HISTORY: Created by Jim Paradise on February 6, 1980. 81-07-01 Jim Gray : added an init entry, so that after a file is read all the way to EOF, the indx_cb.transaction_code can be reset for the next get_nest call after a positon to BOF in mrds_dsl_search. 81-08-29 Davids: Change actually made by L. Spratt. Changed the logic to determine if the current record is an indirect record or the actual record. It used to overlay the ind_structure now it checks specific bits in the record_block_structure. 82-07-06 R. Harvey: Changed $init and $next entry points to $scan_records_init and $scan_records_next. 82-08-11 Mike Kubicar: Added fix for phx12335. Mu_scan_records will honor the vfile_ wait time. Also changed the error code returned when the vfile_ is locked to error_table_$file_busy so that retrieve won't return different error codes for similar condition. 82-09-29 R. Harvey: Renamed and reformatted for vfile_relgmr_ 83-03-24 Roger Lackey : Added code to return a 0 vfile_desc for stationary records that have moved. Also added the locking for the case where vrm is not locking. This involved creating the vrmu_scan_rec_next structure. 83-04-07 R. Harvey : Added check to insure that record being returned is actually data and not a vfile_relmgr_ overhead record. 83-05-12 R. Harvey : Added the extend_seg_ptr_array routine from vfile_ with a slight modification so that it is extended to the proper size in one fell swoop. 83-08-09 R. Harvey : Write-around for TR phx15467 was installed. Kudos to Bert Moberg for identifying a solution. */ %page; /* BEGIN CHANGE 81-07-01 *********************************************** */ init: scan_records_init: entry (iocb_ptr, P_code); /* reset the end of file indicator */ indx_cb_ptr = iocb_ptr -> iocb.open_data_ptr; P_code = 0; indx_cb.transaction_code = 262144; /* -1 => EOF, 262144 => middle of file */ return; /* END CHANGE 81-07-01 ********************************************** */ next: scan_records_next: entry (vrmu_scan_rec_next_ptr, P_code); indx_cb_ptr = vrmu_scan_rec_next.iocb_ptr -> iocb.open_data_ptr; vrmu_scan_rec_next.block_ptr, vrmu_scan_rec_next.record_ptr = null; vrmu_scan_rec_next.descriptor, P_code = 0; f_b_ptr = indx_cb.file_base_ptr; /* establish the file_base */ if indx_cb.transaction_code = -1 then do; P_code = error_table_$end_of_info; return; end; read_count = 0; /* Init */ start_read: if vrmu_scan_rec_next.scan_records_should_lock then do; read_count = read_count + 1; if read_count > divide (indx_cb.wait_time, 1000000, 17, 0) then do; P_code = error_table_$file_busy; return; end; if file_base.lock_word ^= "0"b then do; call timer_manager_$sleep (1, "11"b); /* wait a time */ goto start_read; end; /* get data from file */ end; /* END of scan_records must lock */ save_change_count = file_base.change_count; if indx_cb.at_bof then do; indx_cb.at_bof = "0"b; indx_cb.transaction_code = 262144; end; try_descriptor = indx_cb.transaction_code; scan_status = CONTINUE; do while (scan_status = CONTINUE); if try.comp_num > hbound (seg_ptr_array, 1) then call extend_seg_ptr_array; if seg_ptr_array (try.comp_num) = null then do; call msf_manager_$get_ptr (indx_cb.fcb_ptr, (try.comp_num), DONT_CREATE, seg_ptr_array (try.comp_num), bit_count, code); if code ^= 0 then scan_status = EOF; else scan_status = CONTINUE; end; else if try.offset >= abs (seg_limit (try.comp_num)) then do; try.comp_num = try.comp_num + 1; try.offset = 0; if try.comp_num > file_base.last_comp_num then scan_status = EOF; end; else do; try_block_ptr = addrel (seg_ptr_array (try.comp_num), try.offset); try_block_size = try_block_ptr -> record_block_structure.block_size; if try_block_size = 0 then do; try.comp_num = try.comp_num + 1; try.offset = 0; if try.comp_num > file_base.last_comp_num then scan_status = EOF; end; else if substr (try_block_ptr -> record_block_structure.pad, 2, 1) = "0"b /* BEGIN CHANGE 81-08-29 ********** */ then if (try_block_ptr -> record_block_structure.stationary & ^try_block_ptr -> record_block_structure.indirect) | ^try_block_ptr -> record_block_structure.stationary /* END CHANGE 81-08-29 ************ */ then scan_status = RECORD_FOUND; else try.offset = try.offset + try_block_size; else try.offset = try.offset + try_block_size; end; if scan_status = RECORD_FOUND then do; if try_block_ptr -> record_block_structure.stationary = "0"b then do; try_record_len = length (try_block_ptr -> record_block_structure.record); try_record_ptr = addrel (addr (try_block_ptr -> record_block_structure.record), 1); end; else do; try_record_len = length (try_block_ptr -> stat_structure.record); try_record_ptr = addrel (addr (try_block_ptr -> stat_structure.record), 1); end; if try_record_len = 0 | try_record_ptr -> tuple.rel_id ^= vrmu_scan_rec_next.rel_id then do; /* check next record */ try.offset = try.offset + try_block_size; scan_status = CONTINUE; end; end; end; if save_change_count ^= file_base.change_count then goto start_read; /* set return variables */ if scan_status = RECORD_FOUND then do; if vrmu_scan_rec_next.stationary_rec_expected & try_block_ptr -> record_block_structure.stationary = "0"b then vrmu_scan_rec_next.descriptor = 0; else vrmu_scan_rec_next.descriptor = try_descriptor; try.offset = try.offset + try_block_size; indx_cb.transaction_code = try_descriptor; vrmu_scan_rec_next.block_ptr = try_block_ptr; vrmu_scan_rec_next.record_ptr = try_record_ptr; vrmu_scan_rec_next.record_len = try_record_len; end; else if scan_status = EOF then do; indx_cb.transaction_code = -1; P_code = error_table_$end_of_info; end; else if code ^= 0 then P_code = code; return; /* next entry */ extend_seg_ptr_array: proc; old_array_limit = seg_ptr_array_limit; old_array_ptr = seg_ptr_array_ptr; seg_ptr_array_limit = file_base.last_comp_num; allocate seg_ptr_array in (get_system_free_area_ () -> cb_area) set (seg_ptr_array_ptr); do i = 0 to old_array_limit; seg_ptr_array (i) = old_array (i); end; do i = old_array_limit + 1 to seg_ptr_array_limit; seg_ptr_array (i) = null (); end; free old_array; /* in systemfree */ dcl cb_area area based; dcl get_system_free_area_ entry () returns (ptr); dcl i fixed bin; dcl old_array_limit fixed bin; dcl old_array_ptr ptr; dcl old_array (0:old_array_limit) ptr based (old_array_ptr); end extend_seg_ptr_array; %page; %include vfile_indx; %page; %include iocb; %page; %include vrm_tuple; %page; %include vrm_rel_desc; %page; %include vrmu_scan_rec_next; %page; dcl CONTINUE fixed bin internal static options (constant) init (0); dcl DONT_CREATE bit (1) init ("0"b) internal static options (constant); dcl EOF fixed bin internal static options (constant) init (2); dcl RECORD_FOUND fixed bin internal static options (constant) init (1); dcl iocb_ptr ptr; dcl P_code fixed bin (35); dcl addrel builtin; dcl hbound builtin; dcl bit_count fixed bin (24); dcl code fixed bin (35); dcl error_table_$end_of_info fixed bin (35) external; dcl msf_manager_$get_ptr entry (ptr, fixed bin, bit (1), ptr, fixed bin (24), fixed bin (35)); dcl pos_ptr ptr; /* This var is not referenced, but a a compilor warning is issued if it isn't here */ dcl read_count fixed bin; dcl error_table_$file_busy fixed bin (35) ext static; dcl timer_manager_$sleep entry (fixed bin (71), bit (2)); dcl save_change_count fixed bin (35); dcl scan_status fixed bin; dcl try_block_ptr ptr; dcl try_block_size fixed bin (21); dcl try_descriptor fixed bin (35); dcl 1 try based (addr (try_descriptor)), 2 comp_num fixed bin (17) unaligned, 2 offset fixed bin (18) unsigned unaligned; dcl try_record_len fixed bin (21); dcl try_record_ptr ptr; end vrmu_scan_records;  vrmu_search.pl1 03/06/85 0822.1r w 03/05/85 0836.6 245277 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ vrmu_search: proc (I_search_info_ptr, I_cursor_ptr, O_code); /* BEGIN_DESCRIPTION This proceedure must be preceeded by a call to vrmu_search_init for its setup. It will search the given cursors iocb for the tuples that meed the vrm_search_list constraints either using scan records or key search depending on the cursor type. END_DESCRIPTION HISTORY 82-09-23 Roger Lackey : Originally written 83-04-14 Roger Lackey : rewritten to use new vrm_search_list structure. 83-05-24 Roger Lackey: replaced call to record_status to get record_ptr with call to vrmu_cv_vf_desc_to_ptr 83-09-08 Roger Lackey : Modified extensively to use new vrm_search_info structure and new calling sequence . 83-10-01 Roger Lackey : Modified to do seek head on multi-attribute keys 83-10-11 Roger Lackey : Changed calculation of max_items to account for number of items already_returned. 83-10-25 Roger Lackey : Removed init_required = "1"b when vrm_search_list.num_and_groups = 0 As vrmu_scan_records$scan_records_init is done in vrmu_search_init. */ %page; /* vrmu_search: proc (I_search_info_ptr, I_cursor_ptr, O_tuple_id, O_tuple_ptr, O_code); */ dcl I_search_info_ptr ptr parameter; /* Pointer vrm_search_info structure */ dcl I_cursor_ptr ptr parameter; /* Pointer to vrm_cursor */ dcl O_code fixed bin (35) parameter; /* Error code */ vrm_search_info_ptr = I_search_info_ptr; vrm_cursor_ptr = I_cursor_ptr; O_code = 0; vrm_search_info.num_items_returned = 0; tid_required = vrm_search_info.tuple_tid_required; pointer_required = vrm_search_info.tuple_pointer_required; if ^pointer_required then max_items = vrm_search_info.max_number_values - vrm_search_info.cur_id_list_ix; else max_items = min (vrm_search_info.max_number_values - vrm_search_info.cur_id_list_ix, MAX_SEARCH_ITEMS); vrm_open_info_ptr = vrm_cursor.open_info_ptr; /* Needed local variables */ vrm_rel_desc_ptr = vrm_cursor.vrm_relation_desc_ptr; vrm_search_list_ptr = vrm_cursor.search_list_ptr; file_id = vrm_rel_desc.file_id; if vrm_search_info.meter_sw then vrm_search_info.last_call_stats.num_times_search_called = vrm_search_info.last_call_stats.num_times_search_called + 1; iocb_ptr = vrm_cursor.iocb_ptr; tuple_ptr = null; scan_records_flag = "0"b; /* Until we decide other wise */ init_required = "0"b; cur_ag = vrm_search_list.current_and_group; %page; if vrm_search_list.num_and_groups = 0 then do; num_constraints = 0; scan_records_flag = "1"b; end; else do; if vrm_search_list.and_groups (cur_ag).do_not_use_sw then call error (dm_error_$no_tuple); num_constraints = vrm_search_list.and_groups (cur_ag).num_cons_in_this_and_group; if vrm_search_list.and_groups (cur_ag).collection_id_supplied_sw & vrm_search_list.and_groups (cur_ag).collection_id = RELATION_COLLECTION_ID then scan_records_flag = "1"b; if vrm_search_list.and_groups (cur_ag).must_initialize_sw then init_required = "1"b; end; if ^scan_records_flag then do; kh.rel_id = vrm_rel_desc.rel_id; kh.index_id = substr (vrm_search_list.and_groups (cur_ag).collection_id, 1, 8); kh.mbz = "0"b; end; if init_required then do; if scan_records_flag then do; call vrmu_scan_records$scan_records_init (iocb_ptr, code); if code ^= 0 then call error (code); if vrm_search_list.num_and_groups > 0 then vrm_search_list.and_groups (cur_ag).must_initialize_sw = "0"b; /* We just did it */ end; else call key_seek_head; end; %page; if scan_records_flag then do; /* scan_records looks at all records in the file with out touching the b-tree (key-tree) */ vsrn.iocb_ptr = iocb_ptr; vsrn.stationary_rec_expected = vrm_rel_desc.switches.stationary_records; vsrn.scan_records_should_lock = ^vrm_open_info.switches.shared; vsrn.rel_id = vrm_rel_desc.rel_id; got_one = "0"b; /* This gets turned on when a tuples that passes all search contraints */ do while (vrm_search_info.num_items_returned < max_items); call vrmu_scan_records$next (addr (vsrn), code); if code ^= 0 then do; if code = error_table_$end_of_info then call error (dm_error_$no_tuple); else call error (code); end; tuple_ptr = vsrn.record_ptr; if vrm_search_info.meter_sw then vrm_search_info.last_call_stats.records_searched = vrm_search_info.last_call_stats.records_searched + 1; if num_constraints = 0 then got_one = "1"b; /* No search specification */ else got_one = and_group_constraints_ok (cur_ag); if got_one then do; /* If passes all search constraints */ got_one = "0"b; vrm_search_info.num_items_returned = vrm_search_info.num_items_returned + 1; if pointer_required then vrm_search_info.tup_ptr (vrm_search_info.num_items_returned) = tuple_ptr; if tid_required then do; if vsrn.descriptor (1) = 0 then /* Cause we gota return tuple id */ call get_tuple_tid (tuple_ptr, vsrn.descriptor (1)); vfd_ptr = addr (vsrn.descriptor (1)); tid_ptr = addr (tuple_id); tid.non_std_desc = "1"b; tid.temp = "0"b; tid.file_id = file_id; tid.comp_num = vfd.comp_number; tid.offset = vfd.comp_offset; vrm_search_info.tid_list_ptr -> element_id_list.id (vrm_search_info.num_items_returned + vrm_search_info.cur_id_list_ix) = tuple_id; end; end; end; /* END do while (^got_one) */ end; /* END scan_records */ %page; else do; /* Some kind of key search */ unspec (gk.flags) = "0"b; gk.flags.position_spec.current = "1"b; key_templet_ptr = addr (gk.key_len); /* Pointer to key returned from get_key control order */ key_templet.unused = "0"b; do while (vrm_search_info.num_items_returned < max_items); call get_next; /* Get next tuple that passes key constraints */ end; end; /* END else do some kind of key search */ exit: return; %page; /* * * * * * * * * * * * * * * * * * get_next * * * * * * * * * * */ get_next: proc; /* If a seek_head was done, this will now read that key. If a search specification with constraints that need to be applied to the key exists they will be done here without reading the record. If non-key-constraints exists, they will also be check after getting a pointer to the tuple. If an attribute fails its search specification constraint, another key is read until one is found that passes or until no more keys exists for the cursor */ got_one = "0"b; do while (^got_one); /* Do until we get a tuple that passes the search_specification or exhaust key */ call iox_$control (iocb_ptr, "get_key", addr (gk), code); if code ^= 0 then do; if code = error_table_$no_record | code = error_table_$asynch_deletion | code = error_table_$no_key then call error (dm_error_$no_tuple); else call error (code); end; if vrm_search_info.meter_sw then vrm_search_info.last_call_stats.keys_read = vrm_search_info.last_call_stats.keys_read + 1; /* If first three character are not index id for this collection then we are done */ if substr (gk.key, 1, 3) ^= kh_char_3 then /* Exausted this cursors keys */ call error (dm_error_$no_tuple); %page; /* Apply search_spec constraints to key attributes first */ if vrm_search_list.and_groups (cur_ag).num_key_cons_in_this_and_group > 0 then do; cons_ok = "1"b; if ^vrm_search_list.and_groups (cur_ag).full_key_equal_only_sw then do c = 1 to vrm_search_list.and_groups (cur_ag).num_key_cons_in_this_and_group while (cons_ok); if vrm_search_list.and_groups (cur_ag).cons (c).key_attr_sw then do; if vrm_search_info.meter_sw then vrm_search_info.last_call_stats.keys_compared = vrm_search_info.last_call_stats.keys_compared + 1; spec_val_ptr = vrm_search_list.and_groups (cur_ag).cons (c).encoded_key_ptr; if vrm_search_list.and_groups (cur_ag).cons (c).key_offset = 0 then tuple_key_val_ptr = addr (key_templet.key_data); else tuple_key_val_ptr = add_bit_offset_ (addr (key_templet.key_data), (vrm_search_list.and_groups (cur_ag).cons (c).key_offset)); vrm_collection_info_ptr = vrm_search_list.and_groups (cur_ag).collection_info_ptr; call key_compare (tuple_key_val_ptr, spec_val_ptr, vrm_search_list.and_groups (cur_ag).cons (c).key_bit_length, vrm_search_list.and_groups (cur_ag).cons (c).operator, cons_ok); if cons_ok & vrm_search_info.meter_sw then vrm_search_info.last_call_stats.key_hits = vrm_search_info.last_call_stats.key_hits + 1; if ^cons_ok & vrm_search_list (cur_ag).cons (c).and_group_search_terminator then do; if vrm_search_list.and_groups (cur_ag).cons (c).operator = 1 then vrm_search_info.upper_limit_exceeded_sw = "1"b; else do; op = terminator_op (vrm_search_list.and_groups (cur_ag).cons (c).operator); call key_compare (tuple_key_val_ptr, spec_val_ptr, vrm_search_list.and_groups (cur_ag).cons (c).key_bit_length, op, vrm_search_info.upper_limit_exceeded_sw); end; if vrm_search_info.upper_limit_exceeded_sw then do; vrm_search_list.and_groups (cur_ag).do_not_use_sw = "1"b; call error (dm_error_$no_tuple); end; end; /* END if ^cons_ok */ end; /* END if key_attr */ end; /* END do c = 1 to ** */ %page; if cons_ok then do; call get_tid_and_tuple_ptr; /* Internal procedure */ if tuple_ptr ^= null then got_one = and_group_constraints_ok (cur_ag); /* Check non-key constraints */ else got_one = "1"b; /* By key comparison only */ end; /* END if cons_ok */ end; /* END if vrm_search_list.and_groups (cur_ag).num_key_cons_in_this_and_group > 0 then do */ else do; /* No key constraints */ call get_tid_and_tuple_ptr; /* Internal procedure */ got_one = and_group_constraints_ok (cur_ag); /* Check non-key constraints */ end; if got_one then do; vrm_search_info.num_items_returned = vrm_search_info.num_items_returned + 1; if pointer_required then vrm_search_info.tup_ptr (vrm_search_info.num_items_returned) = tuple_ptr; if tid_required then vrm_search_info.tid_list_ptr -> element_id_list.id (vrm_search_info.num_items_returned + vrm_search_info.cur_id_list_ix) = tuple_id; end; if vrm_search_list.and_groups (cur_ag).full_key_equal_only_sw then do; vrm_search_list.and_groups (cur_ag).do_not_use_sw = "1"b; call error (dm_error_$no_tuple); end; /* In all cases position to next key */ call iox_$position (iocb_ptr, 0, 1, code); if code ^= 0 then do; /* Maybe EOF */ if code = error_table_$end_of_info | code = error_table_$asynch_deletion then call error (dm_error_$no_tuple); else call error (code); end; end; /* end do while (^got_one); */ /* If we get here we have a tuple that has passed all constraints of current and group */ end get_next; %page; /* * * * * * * * * * * * get_tid_and_tuple_ptr * * * * * * * * * * * * * */ get_tid_and_tuple_ptr: proc; if gk.desc < 0 then do; /* If negative it is a tid (non standard vfile desc ) */ unspec (tuple_id) = unspec (gk.desc); tid_ptr = addr (gk.desc); vfd_ptr = addr (vfile_desc); vfile_desc = 0; vfd.comp_number = tid.comp_num; vfd.comp_offset = tid.offset; end; else do; /* It is a real vfile desc */ vfile_desc = gk.desc; vfd_ptr = addr (gk.desc); tid_ptr = addr (tuple_id); tid.non_std_desc = "1"b; tid.temp = "0"b; tid.file_id = file_id; tid.comp_num = vfd.comp_number; tid.offset = vfd.comp_offset; end; if pointer_required | (vrm_search_list.and_groups (cur_ag).num_cons_in_this_and_group - vrm_search_list.and_groups (cur_ag).num_key_cons_in_this_and_group) > 0 then do; /* Convert vfile desc to record ptr */ call vrmu_cv_vf_desc_to_ptr (iocb_ptr, vfile_desc, tuple_ptr, rec_len, code); if code ^= 0 then call error (code); end; end get_tid_and_tuple_ptr; %page; /* * * * * * * * * * * * * * key_compare * * * * * * * * * * * * */ /* Compares two key values using one of six operators */ key_compare: proc (I_key_one_ptr, I_key_two_ptr, I_key_len, I_operator, O_result); dcl I_key_one_ptr ptr parameter; /* Pointer to first key value */ dcl I_key_two_ptr ptr parameter; /* Pointer to second key value */ dcl I_key_len fixed bin (17) unal parameter; /* Length of both key values in bits */ dcl I_operator fixed bin (17) unal parameter; /* Comparison operator */ dcl O_result bit (1) aligned parameter; /* Returned results One = true */ dcl key_one bit (I_key_len) unaligned based (I_key_one_ptr); dcl key_two bit (I_key_len) unaligned based (I_key_two_ptr); goto k_compare (I_operator); k_compare (1): /* Operator: = */ if key_one = key_two then O_result = "1"b; else O_result = "0"b; return; k_compare (2): /* Operator: > */ if key_one > key_two then O_result = "1"b; else O_result = "0"b; return; k_compare (3): /* Operator: >= */ if key_one >= key_two then O_result = "1"b; else O_result = "0"b; return; k_compare (5): /* Operator: ^= */ if key_one ^= key_two then O_result = "1"b; else O_result = "0"b; return; k_compare (6): /* Operator: <= */ if key_one <= key_two then O_result = "1"b; else O_result = "0"b; return; k_compare (7): /* Operator: < */ if key_one < key_two then O_result = "1"b; else O_result = "0"b; return; end key_compare; %page; /* * * * * * * * * * * * * * * * get_tuple_tid * * * * * * * * * * * * */ /* Gets a tid given the tuple pointer */ get_tuple_tid: proc (I_tuple_ptr, O_vf_desc); dcl I_tuple_ptr ptr parameter; dcl O_vf_desc fixed bin (35) parameter; tuple_ptr = I_tuple_ptr; bit_len = 9 * vrm_rel_desc.maximum_data_length; bd_ptr = addr (tuple.data); key_source_list.number_of_values = vrm_rel_desc.number_primary_key_attrs; do i = 1 to vrm_rel_desc.number_primary_key_attrs;/* copy out values and build key source list */ vrm_attr_info_ptr = addr (vrm_rel_desc.attr (vrm_open_info.primary_key_info_ptr -> vrm_collection_info.attribute (i).attr_index)); /* to attr info */ key_source_list.val_info.val_ptr (i) = addr (key_vals (i)); /* set source value ptr */ key_source_list.val_info.desc_ptr (i) = addr (vrm_attr_info.descriptor); /* and ptr to descr. */ if vrm_attr_info.varying then do; /* if var. attr. */ offset = tuple.var_offsets (vrm_attr_info.bit_offset); /* bit offset */ key_source_list.val_info.val_ptr (i) = addr (bit_data (offset)); end; /* if varying */ else key_source_list.val_info.val_ptr (i) -> bit_str = substr (data_str, vrm_attr_info.bit_offset, vrm_attr_info.bit_length); end; /* building key source list */ call vrmu_encode_key (addr (key_source_list), pgk.key, (0), code); if code ^= 0 then call error (code); /* Now finish up the header on the primary key */ index_ptr = addrel (addr (pgk.key), 1); /* past length word of varying string */ index_value_length = 0; /* save warning flag */ index.rel_id = vrm_rel_desc.rel_id; index.index_id = "0"b; unspec (pgk.flags) = "0"b; pgk.input_key = "1"b; pgk.flags.pspec.head_size = length (pgk.key); call iox_$control (vrm_cursor.iocb_ptr, "get_key", addr (pgk), code); if code ^= 0 then call error (code); O_vf_desc = pgk.descriptor; return; end get_tuple_tid; %page; /* * * * * * * * * * * * * * and_group_constraints_ok * * * * * * * * * * * */ and_group_constraints_ok: proc (and_group_ix) returns (bit (1)); dcl and_group_ix fixed bin parameter; ret_val = "0"b; if num_constraints > 0 then do; cons_ok = "1"b; do c = 1 to vrm_search_list.and_groups (and_group_ix).num_cons_in_this_and_group while (cons_ok); check_it = "0"b; if vrm_search_list.and_groups (and_group_ix).num_key_cons_in_this_and_group > 0 then do; if ^vrm_search_list.and_groups (and_group_ix).cons (c).key_attr_sw then check_it = "1"b; end; else check_it = "1"b; if check_it then do; /* Check this constraint */ if vrm_search_info.meter_sw then vrm_search_info.last_call_stats.non_key_compares = vrm_search_info.last_call_stats.non_key_compares + 1; compare_op = vrm_search_list.and_groups (and_group_ix).cons (c).operator; spec_val_ptr = vrm_search_list.and_groups (and_group_ix).cons (c).val_ptr; desc_ptr = vrm_search_list.and_groups (and_group_ix).cons (c).attr_desc_ptr; fx = vrm_search_list.and_groups (and_group_ix).cons (c).attr_index; if vrm_rel_desc.attr (fx).varying then /* Set pointer to attribute in tuple */ tuple_attr_ptr = add_bit_offset_ (addr (tuple.data), tuple.var_offsets (vrm_rel_desc.attr (fx).bit_offset) - 1); else tuple_attr_ptr = add_bit_offset_ (addr (tuple.data), vrm_rel_desc.attr (fx).bit_offset - 1); /* Note that a -1 is needed because a bit_offset = 1 indicate the first bit which is realy an off set of 0 */ call vrmu_compare_values (tuple_attr_ptr, desc_ptr, spec_val_ptr, desc_ptr, compare_op, cons_ok, code); if code ^= 0 then call error (code); if vrm_search_info.meter_sw & cons_ok then vrm_search_info.last_call_stats.non_key_hits = vrm_search_info.last_call_stats.non_key_hits + 1; end; end; /* END DO c = 1 to */ if cons_ok then ret_val = "1"b; end; /* END if num_constrainsts > 0 */ else ret_val = "1"b; /* No search specification */ return (ret_val); end and_group_constraints_ok; %page; /* * * * * * * * * * * * key_seek_head * * * * * * * * * * * * * * * */ key_seek_head: proc; key_source_list.number_of_values = 0; seek_head_type = 0; /* Until we know differnt */ seek_head_key = kh_char_3; if vrm_search_list.and_groups (cur_ag).seek_key_con_ix ^= 0 then do; if vrm_search_list.and_groups (cur_ag).multi_attr_seek_head_sw then do; num_key_head_attrs = 0; do z = 1 to vrm_search_list.and_groups (cur_ag).num_key_cons_in_this_and_group; if vrm_search_list.and_groups (cur_ag).cons (z).seek_head_sw then do; num_key_head_attrs = num_key_head_attrs + 1; shx = vrm_search_list.and_groups (cur_ag).cons (z).attr_position_in_key; key_source_list.val_info (shx).val_ptr = vrm_search_list.and_groups (cur_ag).cons (z).val_ptr; key_source_list.val_info (shx).desc_ptr = vrm_search_list.and_groups (cur_ag).cons (z).attr_desc_ptr; end; end; /* END do z */ key_source_list.number_of_values = num_key_head_attrs; call vrmu_encode_key (addr (key_source_list), temp_key, (0), code); if code ^= 0 then call error (code); key_ptr = addcharno (addr (temp_key), 7); key_len = length (temp_key) - 3; end; else do; /* key_source_list.number_of_values = 0 */ shx = vrm_search_list.and_groups (cur_ag).seek_key_con_ix; key_ptr = vrm_search_list.and_groups (cur_ag).cons (shx).encoded_key_ptr; key_len = vrm_search_list.and_groups (cur_ag).cons (shx).encoded_key_length; end; seek_head_key = seek_head_key || key; /* seek_head_key already had the vrm_cursor.key_head prefix for this cursor in it */ if vrm_search_list.and_groups (cur_ag).cons (shx).operator = 1 then seek_head_type = 0; else if vrm_search_list.and_groups (cur_ag).cons (shx).operator = 3 then seek_head_type = 1; else seek_head_type = 2; if vrm_search_info.meter_sw then vrm_search_info.last_call_stats.special_seek_heads = vrm_search_info.last_call_stats.special_seek_heads + 1; end; else if vrm_search_info.meter_sw then vrm_search_info.last_call_stats.seek_heads = vrm_search_info.last_call_stats.seek_heads + 1; seek_head.rel_type = seek_head_type; seek_head.num_head_chars = length (seek_head_key); seek_head.key_chars = seek_head_key; call iox_$control (iocb_ptr, "seek_head", addr (seek_head), code); if code ^= 0 then do; if code = error_table_$no_record | code = error_table_$no_key then call error (dm_error_$no_tuple); else call error (code); end; vrm_search_list.and_groups (cur_ag).must_initialize_sw = "0"b; /* We just did it */ end key_seek_head; %page; /* * * * * * * * * * * * * * * error * * * * * * * * * * * * * * * */ error: proc (cd); dcl cd fixed bin (35) parameter; O_code = cd; goto exit; end error; %page; %include vrm_cursor; %page; %include vrm_search_list; %page; %include vrm_open_info; %page; %include vrm_rel_desc; %page; %include vrm_collection_info; %page; %include vrm_meter; %page; %include dm_element_id_list; %page; %include dm_typed_vector_list; %page; %include vrm_tuple; %page; %include vrm_search_info; %page; %include vrmu_scan_rec_next; %page; %include vrm_index; %page; dcl 1 vsrn aligned like vrmu_scan_rec_next; dcl 1 gk, 2 flags aligned, 3 input_key bit (1) unal, 3 input_desc bit (1) unal, 3 desc_code fixed bin (2) unal, 3 position_spec unal, 4 current bit (1) unal, /* Want info about current index */ 4 rel_type fixed bin (2) unal, 4 head_size fixed bin (9) unsigned unal, 3 reset_pos bit (1) unal, 3 mbz bit (8) unal, 3 version fixed bin (8) unal, 2 desc fixed bin (35), 2 key_len fixed bin, 2 key char (256); dcl key_templet_ptr ptr; dcl 1 key_templet based (key_templet_ptr), 2 unused bit (12) unal, 2 len fixed bin (23) unal, 2 prefix char (3) unal, 2 key_data char (253); dcl 1 tid aligned based (tid_ptr), /* MRDS tuple id (tid) */ 2 non_std_desc bit (1) unal, /* Non-standard descriptor bit */ 2 temp bit (1) unal, /* On if temp relation */ 2 file_id bit (7) unal, /* File id from mrds db_model file_id_list */ 2 comp_num bit (10) unal, /* Component number */ 2 offset bit (17) unal; /* Offset within component */ dcl tid_ptr pointer; dcl 1 vfd aligned based (vfd_ptr), /* Vfile desc */ 2 pad_1 bit (8) unal, 2 comp_number bit (10) unal, /* Component number */ 2 comp_offset bit (17) unal, /* Offset with in component */ 2 pade_2 bit (1) unal; dcl vfd_ptr pointer; /* Pointer to vfd structure */ %page; dcl 1 kh unaligned, /* Key prefix head */ 2 rel_id bit (12) unaligned, 2 index_id bit (8) unaligned, 2 mbz bit (7) unaligned; dcl kh_char_3 char (3) based (addr (kh)); dcl 1 seek_head, /* Seek head info */ 2 rel_type fixed bin, 2 num_head_chars fixed bin, 2 key_chars char (256); dcl 1 pgk, /* Primary get_key info Like gk_info */ 2 flags aligned, 3 input_key bit (1) unal init ("1"b), 3 input_desc bit (1) unal, 3 desc_code bit (3) unal, 3 pspec unal, 4 current bit (1) unal, 4 rel_type bit (3) unal, 4 head_size fixed bin (9) unsigned unal, 3 reset_pos bit (1) unal, 3 mbz bit (8) unal, 3 version bit (8) unal, 2 descriptor fixed bin (35), 2 key char (256) varying; dcl 1 key_source_list aligned, 2 number_of_values fixed bin, /* Number of attributes in primary key */ 2 val_info (253), /* FROM vrm_data_$max_kattr_length it is uses as a constant because of performance */ 3 val_ptr ptr, /* Pointer to attr value */ 3 desc_ptr ptr; /* Pointer to attr desc */ %page; dcl addbitno builtin; dcl add_bit_offset_ entry (ptr, fixed bin (24)) returns (ptr) reducible; dcl addcharno builtin; dcl addr builtin; dcl addrel builtin; dcl bd_ptr ptr; dcl bit_data (bit_len) bit (1) unal based (bd_ptr); dcl bit_len fixed bin (35); dcl bit_str bit (vrm_attr_info.bit_length) based; dcl c fixed bin; dcl check_it bit (1) aligned; dcl code fixed bin (35); dcl compare_op fixed bin; dcl cons_ok bit (1) aligned; dcl cur_ag fixed bin; dcl data_str bit (bit_len) based (bd_ptr); dcl dm_error_$no_tuple fixed bin (35) ext static; dcl error_table_$asynch_deletion fixed bin (35) ext static; dcl error_table_$end_of_info fixed bin (35) ext static; dcl error_table_$no_key fixed bin (35) ext static; dcl error_table_$no_record fixed bin (35) ext static; dcl file_id bit (7) aligned; dcl fx fixed bin; dcl got_one bit (1); dcl i fixed bin; dcl tid_required bit (1) aligned; dcl init_required bit (1) aligned; dcl iocb_ptr ptr; dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl iox_$position entry (ptr, fixed bin, fixed bin (21), fixed bin (35)); dcl key char (key_len) based (key_ptr); dcl key_len fixed bin; dcl key_ptr ptr; dcl key_vals (253) char (253); /* to hold values so they are aligned */ dcl length builtin; dcl max_items fixed bin (35); dcl min builtin; dcl null builtin; dcl num_constraints fixed bin; dcl num_key_head_attrs fixed bin; dcl offset fixed bin (35); /* temp attr offset */ dcl op fixed bin (17) unal; dcl pointer_required bit (1) aligned; dcl rec_len fixed bin (21); dcl RELATION_COLLECTION_ID bit (36) int static options (constant) init ("111111111111111111111111111111111111"b); dcl ret_val bit (1) aligned; dcl scan_records_flag bit (1) aligned; dcl seek_head_key char (256) varying; dcl seek_head_type fixed bin; dcl shx fixed bin; dcl spec_val_ptr ptr; dcl substr builtin; dcl terminator_op (7) fixed bin int static options (constant) init (2, 0, 0, 0, 0, 2, 3); dcl tuple_attr_ptr ptr; dcl tuple_id bit (36) aligned; dcl tuple_key_val_ptr ptr; dcl unspec builtin; dcl vfile_desc fixed bin (35) aligned; dcl vrmu_compare_values entry (ptr, ptr, ptr, ptr, fixed bin, bit (1) aligned, fixed bin (35)); dcl vrmu_cv_vf_desc_to_ptr entry (ptr, fixed bin (35), ptr, fixed bin (21), fixed bin (35)); dcl vrmu_encode_key entry (ptr, char (256) varying, fixed bin (35), fixed bin (35)); dcl vrmu_scan_records$next entry (ptr, fixed bin (35)); dcl vrmu_scan_records$scan_records_init entry (ptr, fixed bin (35)); dcl temp_key char (256) varying; dcl z fixed bin; dcl desc_ptr ptr; end vrmu_search;  vrmu_search_init.pl1 11/23/84 0800.9rew 11/21/84 0920.3 230697 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ vrmu_search_init: proc (I_cursor_ptr, I_spec_ptr, O_code); dcl I_cursor_ptr ptr parameter; /* Pointer to vrm_cursor */ dcl I_spec_ptr ptr parameter; /* Pointer to dm_relation_search_specification*/ dcl O_code fixed bin (35) parameter; /* Error code */ /* BEGIN_DESCRIPTION This module builds the vrm_search_list. It is called from vrm_get_by_spec to initialize for vrmu_search. If a relation_search_specification constriants are supplied they are translated to the vrm_search_list. If a collection_id was supplied in the relation_search_specification and key attribute constraints are supplied the vrm_search_list is optimized and setup for a seek_head (done in vrmu_search) is done. All key attribute constraints are compared to other constraints on the same attribute. Inconsistent constraints cause the switch do_not_use_sw to be set. Duplicate constraints are removed. END_DESCRIPTION HISTORY: Written by Roger Lackey: 83-10-01 Roger Lackey : modified to handle multi attribute keys in seek headed setup. 83-10-25 Roger Lackey : Added vrmu_scan_records$scan_records_init for the case where num_and_groups = 0; 84-06-11 Bert Moberg : Major rewrite to fix several problems including not using all of the available key head and a sort loop that did not sort. */ /* vrmu_search_init: proc (I_cursor_ptr, I_spec_ptr, O_code); */ /* Init parameters */ vrm_cursor_ptr = I_cursor_ptr; relation_search_specification_ptr = I_spec_ptr; O_code = 0; /* Init local variables */ vrm_open_info_ptr = vrm_cursor.open_info_ptr; vrm_com_ptr = vrm_open_info.com_ptr; vrm_rel_desc_ptr = vrm_cursor.vrm_relation_desc_ptr; num_search_keys_used = 0; /* Clean up old storage */ if vrm_cursor.search_list_ptr ^= null then free vrm_cursor.search_list_ptr -> vrm_search_list; vrm_cursor.search_list_ptr = null; if vrm_cursor.search_keys_ptr ^= null then free vrm_cursor.search_keys_ptr -> search_keys; vrm_cursor.search_keys_ptr = null; if relation_search_specification_ptr = null then do; vsl_number_of_and_groups = 0; vsl_max_number_of_constraints = 0; allocate vrm_search_list in (get_area) set (vrm_search_list_ptr); vrm_cursor.search_list_ptr = vrm_search_list_ptr; vrm_search_list.num_and_groups = vsl_number_of_and_groups; vrm_search_list.max_num_constraints = vsl_max_number_of_constraints; end; else do; /* relation_search_specification_ptr ^= null */ call vrmu_validate_spec (vrm_cursor_ptr, relation_search_specification_ptr, alloc_num_search_keys, code); if code ^= 0 then call error (code); if alloc_num_search_keys > 0 then do; allocate search_keys in (get_area) set (search_keys_ptr); vrm_cursor.search_keys_ptr = search_keys_ptr; ; end; vsl_number_of_and_groups = relation_search_specification.number_of_and_groups; vsl_max_number_of_constraints = relation_search_specification.maximum_number_of_constraints; allocate vrm_search_list in (get_area) set (vrm_search_list_ptr); vrm_cursor.search_list_ptr = vrm_search_list_ptr; vrm_search_list.num_and_groups = vsl_number_of_and_groups; vrm_search_list.max_num_constraints = vsl_max_number_of_constraints; do ag = 1 to relation_search_specification.number_of_and_groups; /* Look at all and groups */ key_head_attr_exists = "0"b; call build_vrm_and_group; if collection_id_found then call validate_all_key_constraints; if key_head_attr_exists & ^vrm_search_list.and_groups (ag).do_not_use_sw then call optimize_and_group; end; end; /* relation_search_specification ^= null */ if vrm_search_list.num_and_groups > 0 then vrm_search_list.current_and_group = 1; else do; /* It has to be scan_records type */ call vrmu_scan_records$scan_records_init (iocb_ptr, code); if code ^= 0 then call error (code); vrm_search_list.current_and_group = 0; end; if db_sw then call vrm_display_search_list$subroutine (vrm_cursor_ptr); exit: return; build_vrm_and_group: proc; /* Fill in the vrm_search_list with info from relation_search_specification from vrm_rel_desc */ vrm_search_list.and_groups (ag).num_cons_in_this_and_group = relation_search_specification.and_group (ag).number_of_constraints; vrm_search_list.and_groups (ag).seek_key_con_ix = 0; vrm_search_list.and_groups (ag).do_not_use_sw = "0"b; vrm_search_list.and_groups (ag).collection_id_supplied_sw = relation_search_specification.and_group (ag).flags.collection_id_supplied; vrm_search_list.and_groups (ag).collection_id = relation_search_specification.and_group (ag).search_collection_id; if vrm_search_list.and_groups (ag).num_cons_in_this_and_group > 0 then vrm_search_list.and_groups (ag).must_initialize_sw = "1"b; vrm_search_list.and_groups (ag).multi_attr_seek_head_sw = "0"b; vrm_search_list.and_groups (ag).full_key_equal_only_sw = "0"b; vrm_collection_info_ptr = null; collection_id_found = "0"b; if vrm_search_list.and_groups (ag).collection_id_supplied_sw then do; if vrm_search_list.and_groups (ag).collection_id = "0"b then do; /* Primary key collection */ collection_id_found = "1"b; vrm_collection_info_ptr = vrm_open_info.primary_key_info_ptr; end; else if vrm_search_list.and_groups (ag).collection_id = RELATION_COLLECTION_ID then do; end; /* Since it is not the relation collection and it is not the primary key collect, it must be an index collection */ else do; do i = 1 to vrm_open_info.number_of_index_collections while (^collection_id_found); if vrm_search_list.and_groups (ag).collection_id = vrm_open_info.index_collection (i).id then do; collection_id_found = "1"b; vrm_collection_info_ptr = vrm_open_info.index_collection (i).info_ptr; end; end; if ^collection_id_found then do; call sub_err_ (mrds_error_$internal_error, "vrmu_search_init", ACTION_CANT_RESTART, null, 0, "A collection_id was specified in the relation_search_specification that was not found in the relation."); end; end; /* index collection id supplied */ end; /* collection id supplied */ vrm_search_list.and_groups (ag).collection_info_ptr = vrm_collection_info_ptr; key_cons_this_group = 0; do c = 1 to relation_search_specification.and_group (ag).number_of_constraints; if relation_search_specification.and_group (ag).constraint (c).value_ptr ^= null then do; call convert_one_constraint; if collection_id_found then call check_for_key_attr; end; else call sub_err_ (mrds_error_$internal_error, "vrmu_search_init", ACTION_CANT_RESTART, null, 0, "A constraint was specified with a null value pointer"); end; vrm_search_list.and_groups (ag).num_key_cons_in_this_and_group = key_cons_this_group; end build_vrm_and_group; /* * * * * * * * * * convert_one_constraint * * * * * * * * * */ convert_one_constraint: proc; unspec (vrm_search_list.and_groups (ag).cons (c)) = "0"b; /* Zero everything */ vrm_search_list.and_groups (ag).cons (c).valid_sw = "1"b; vrm_search_list.and_groups (ag).cons (c).val_ptr = relation_search_specification.and_group (ag).constraint (c).value_ptr; x = relation_search_specification.and_group (ag).constraint (c).field_id; vrm_search_list.and_groups (ag).cons (c).attr_index = x; vrm_search_list.and_groups (ag).cons (c).attr_desc_ptr = addr (vrm_rel_desc.attr (x).descriptor); vrm_search_list.and_groups (ag).cons (c).attr_bit_length = vrm_rel_desc.attr (x).bit_length; vrm_search_list.and_groups (ag).cons (c).encoded_key_ptr = null; vrm_search_list.and_groups (ag).cons (c).operator = relation_search_specification.and_group (ag).constraint (c).operator_code; vrm_search_list.and_groups (ag).cons (c).key_attr_sw = "0"b; /* Until we know better */ return; end convert_one_constraint; /* * * * * * * * * * * * * * * check_for_key_attr * * * * * * * * * * */ check_for_key_attr: proc; key_attr_found = "0"b; do cx = 1 to vrm_collection_info.number_of_attributes while (^key_attr_found); if relation_search_specification.and_group (ag).constraint (c).field_id = vrm_collection_info.attribute (cx).attr_index then do; /* It is a key attribute */ key_attr_found = "1"b; key_cons_this_group = key_cons_this_group + 1; vrm_search_list.and_groups (ag).cons (c).key_attr_sw = "1"b; vrm_search_list.and_groups (ag).cons (c).attr_position_in_key = cx; if vrm_collection_info.attribute (cx).key_offset = 0 then do; vrm_search_list.and_groups (ag).cons (c).key_head_sw = "1"b; key_head_attr_exists = "1"b; if vrm_search_list.and_groups (ag).cons (c).operator < 4 then vrm_search_list.and_groups (ag).cons (c).seek_head_sw = "1"b; end; vrm_search_list.and_groups (ag).cons (c).key_offset = vrm_collection_info.attribute (cx).key_offset; vrm_search_list.and_groups (ag).cons (c).key_bit_length = vrm_collection_info.attribute (cx).key_bit_len; num_search_keys_used = num_search_keys_used + 1; call vrmu_encode_key$encode_attr ((relation_search_specification.and_group (ag).constraint (c).value_ptr), addr (vrm_rel_desc.attr (relation_search_specification.and_group (ag).constraint (c).field_id).descriptor), search_keys (num_search_keys_used), code); if code ^= 0 then call error (code); vrm_search_list.and_groups (ag).cons (c).search_keys_ix = num_search_keys_used; vrm_search_list.and_groups (ag).cons (c).encoded_key_ptr = addrel (addr (search_keys (num_search_keys_used)), 1); vrm_search_list.and_groups (ag).cons (c).encoded_key_length = length (search_keys (num_search_keys_used)); end; /* Found key attribute */ end; /* Look for key attribute */ if key_attr_found then do; /* if the key constraint is not at the begining of the constraint list, put it there */ if c ^= key_cons_this_group then call switch_constraints (c, key_cons_this_group, switched); /* Sort the key constraints in order by their position within the key */ /* If the attributes are in the same position, sort by operator */ switched = "1"b; do cx = key_cons_this_group - 1 to 1 by -1 while (switched); switched = "0"b; /* if position in key wrong */ if vrm_search_list.and_groups (ag).cons (cx).attr_position_in_key > vrm_search_list.and_groups (ag).cons (cx + 1).attr_position_in_key then call switch_constraints (cx, cx + 1, switched); /* else if position in key right, but operators in wrong order */ else if vrm_search_list.and_groups (ag).cons (cx).attr_position_in_key = vrm_search_list.and_groups (ag).cons (cx + 1).attr_position_in_key & vrm_search_list.and_groups (ag).cons (cx).operator > vrm_search_list.and_groups (ag).cons (cx + 1).operator then call switch_constraints (cx, cx + 1, switched); end; /* sort loop */ end; end check_for_key_attr; /* * * * * * * * * * * * * * * validate_all_key_constraints * * * * * * * * * * */ validate_all_key_constraints: proc; c1 = 1; do while (c1 < vrm_search_list.and_groups (ag).num_key_cons_in_this_and_group); retry_c2: do c2 = c1 + 1 to vrm_search_list.and_groups (ag).num_key_cons_in_this_and_group; /* If the current two constraints are on the sma attribute, cross validate them */ if vrm_search_list.and_groups (ag).cons (c1).attr_position_in_key = vrm_search_list.and_groups (ag).cons (c2).attr_position_in_key then do; call validate_constraints (c1, c2, action); go to perform (action); /* keep both constraints */ perform (1): goto next_c2; /* remove first constraint */ perform (2): call remove_key_constraint (c1); goto retry_c2; /* remove second constraint */ perform (3): call remove_key_constraint (c2); goto retry_c2; /* remove second constraint and make first constraint equals operator */ perform (4): call remove_key_constraint (c2); vrm_search_list.and_groups (ag).cons (c1).operator = 1; goto retry_c2; /* kill and group */ perform (5): vrm_search_list.and_groups (ag).do_not_use_sw = "1"b; return; end; /* Two constraints on same attribute */ next_c2: end; /* do while more attributes with same position */ c1 = c1 + 1; end; /* do while more attributes in key */ end validate_all_key_constraints; /* * * * * * * * * * * * * * * validate_constraints * * * * * * * * * * */ validate_constraints: proc (con_1, con_2, action); /* This procedure cross validates two constraints within an and group */ /* This procedure assumes that con_1 < con_2 and cons (con_1).operator <= cons (con_2).operator */ dcl con_1 fixed bin parameter; /* First constraint */ dcl con_2 fixed bin parameter; /* Second constaint */ dcl action fixed bin parameter; goto first_op (vrm_search_list.and_groups (ag).cons (con_1).operator); /* If first operator is equals, then if this value meets the second constraint, the second constraint is not needed. If it does not meet the second constraint, the and group will never match */ first_op (1): /* op1 is =, op2 is ? */ if key_compare (con_1, (vrm_search_list.and_groups (ag).cons (con_2).operator), con_2) then action = REMOVE_B; else action = KILL_AND_GROUP; return; first_op (2): /* op1 is >, op2 is ? */ goto first_op_greater (vrm_search_list.and_groups (ag).cons (con_2).operator); first_op_greater (2): /* op1 is >, op2 is > */ if key_compare (con_1, LESS_OPERATOR_CODE, con_2) then action = REMOVE_A; else action = REMOVE_B; return; first_op_greater (3): /* op1 is >, op2 is >= */ if key_compare (con_1, LESS_OPERATOR_CODE, con_2) then action = REMOVE_A; else action = REMOVE_B; return; first_op_greater (4): /* Not used */ goto bad_code; first_op_greater (5): /* op1 is >, op2 is ^= */ if key_compare (con_1, LESS_OPERATOR_CODE, con_2) then action = KEEP_BOTH; else action = REMOVE_B; return; first_op_greater (6): /* op1 is >, op2 is <= */ if key_compare (con_1, LESS_OPERATOR_CODE, con_2) then action = KEEP_BOTH; else action = KILL_AND_GROUP; return; first_op_greater (7): /* op1 is >, op2 is < */ if key_compare (con_1, LESS_OPERATOR_CODE, con_2) then action = KEEP_BOTH; else action = KILL_AND_GROUP; return; first_op (3): /* op1 is >=, op2 is ? */ goto first_op_greater_or_equal (vrm_search_list.and_groups (ag).cons (con_2).operator); first_op_greater_or_equal (3): /* op1 is >=, op2 is >= */ if key_compare (con_1, LESS_OPERATOR_CODE, con_2) then action = REMOVE_A; else action = REMOVE_B; return; first_op_greater_or_equal (4): /* Not used */ goto bad_code; first_op_greater_or_equal (5): /* op1 is >=, op2 is ^= */ if key_compare (con_1, LESS_OR_EQUAL_OPERATOR_CODE, con_2) then action = KEEP_BOTH; else action = REMOVE_B; return; first_op_greater_or_equal (6): /* op1 is >=, op2 is <= */ if key_compare (con_1, LESS_OPERATOR_CODE, con_2) then action = KEEP_BOTH; else if key_compare (con_1, EQUAL_OPERATOR_CODE, con_2) then action = REMOVE_B_MAKE_A_EQUALS; else action = KILL_AND_GROUP; return; first_op_greater_or_equal (7): /* op1 is >, op2 is < */ if key_compare (con_1, LESS_OPERATOR_CODE, con_2) then action = KEEP_BOTH; else action = KILL_AND_GROUP; return; first_op (4): /* Not used */ bad_code: call sub_err_ (mrds_error_$internal_error, "vrmu_search_init", ACTION_CANT_RESTART, null, 0, "A constraint was specified with an invalid operation code"); first_op (5): /* op1 is ^=, op2 is ? */ goto first_op_not_equal (vrm_search_list.and_groups (ag).cons (con_2).operator); first_op_not_equal (5): /* op1 is ^=, op2 is ^= */ if key_compare (con_1, NOT_EQUAL_OPERATOR_CODE, con_2) then action = KEEP_BOTH; else action = REMOVE_B; return; first_op_not_equal (6): /* op1 is ^=, op2 is <= */ if key_compare (con_1, LESS_OR_EQUAL_OPERATOR_CODE, con_2) then action = KEEP_BOTH; else action = REMOVE_A; return; first_op_not_equal (7): /* op1 is ^=, op2 is < */ if key_compare (con_1, LESS_OPERATOR_CODE, con_2) then action = KEEP_BOTH; else action = REMOVE_A; return; first_op (6): /* op1 is <=, op2 is ? */ goto first_op_less_or_equal (vrm_search_list.and_groups (ag).cons (con_2).operator); first_op_less_or_equal (6): /* op1 is <=, op2 is <= */ if key_compare (con_1, GREATER_OPERATOR_CODE, con_2) then action = REMOVE_A; else action = REMOVE_B; return; first_op_less_or_equal (7): /* op1 is <=, op2 is < */ if key_compare (con_1, GREATER_OR_EQUAL_OPERATOR_CODE, con_2) then action = REMOVE_A; else action = REMOVE_B; return; first_op (7): /* op1 is <, op2 is < */ if key_compare (con_1, GREATER_OPERATOR_CODE, con_2) then action = REMOVE_A; else action = REMOVE_B; return; end validate_constraints; /* * * * * * * * * * * * * * key_compare * * * * * * * * * * * * */ /* Compares two key values using one of six operators */ key_compare: proc (con_1, operator, con_2) returns (bit (1)); dcl con_1 fixed bin parameter; /* First constraint */ dcl con_2 fixed bin parameter; /* Second constaint */ dcl operator fixed bin (17) parameter; /* Comparison operator */ dcl key_one_ptr ptr; /* Pointer to first key value */ dcl key_two_ptr ptr; /* Pointer to second key value */ dcl key_len fixed bin (17); /* Length of both key values in bits */ dcl key_one bit (key_len) based (key_one_ptr); dcl key_two bit (key_len) based (key_two_ptr); key_one_ptr = vrm_search_list.and_groups (ag).cons (con_1).encoded_key_ptr; key_two_ptr = vrm_search_list.and_groups (ag).cons (con_2).encoded_key_ptr; key_len = vrm_search_list.and_groups (ag).cons (con_1).key_bit_length; goto k_compare (operator); k_compare (1): /* Operator: = */ if key_one = key_two then return ("1"b); else return ("0"b); k_compare (2): /* Operator: > */ if key_one > key_two then return ("1"b); else return ("0"b); k_compare (3): /* Operator: >= */ if key_one >= key_two then return ("1"b); else return ("0"b); k_compare (5): /* Operator: ^= */ if key_one ^= key_two then return ("1"b); else return ("0"b); k_compare (6): /* Operator: <= */ if key_one <= key_two then return ("1"b); else return ("0"b); k_compare (7): /* Operator: < */ if key_one < key_two then return ("1"b); else return ("0"b); end key_compare; /* * * * * * * * * * * * * * * remove_key_constraint * * * * * * * * * * */ remove_key_constraint: proc (con); dcl con fixed bin parameter; /* constraint to remove */ dcl cx fixed bin; dcl switched bit (1) aligned; do cx = con to vrm_search_list.and_groups (ag).num_cons_in_this_and_group - 1; call switch_constraints (cx, cx + 1, switched); end; vrm_search_list.and_groups (ag).num_cons_in_this_and_group = vrm_search_list.and_groups (ag).num_cons_in_this_and_group - 1; vrm_search_list.and_groups (ag).num_key_cons_in_this_and_group = vrm_search_list.and_groups (ag).num_key_cons_in_this_and_group - 1; return; end remove_key_constraint; /* * * * * * * * * * * * * * * optimize_and_group * * * * * * * * * * */ optimize_and_group: proc; done_sw = "0"b; last_op_was_equal = "0"b; next_key_pos = 1; num_seek_head_attr = 0; do c = 1 to vrm_search_list.and_groups (ag).num_key_cons_in_this_and_group while (^done_sw); if vrm_search_list.and_groups (ag).cons (c).attr_position_in_key ^= next_key_pos then done_sw = "1"b; else do; last_op_was_equal = "0"b; /* operator is = */ if vrm_search_list.and_groups (ag).cons (c).operator = 1 then do; last_op_was_equal = "1"b; next_key_pos = next_key_pos + 1; num_seek_head_attr = num_seek_head_attr + 1; vrm_search_list.and_groups (ag).cons (c).and_group_search_terminator = "1"b; vrm_search_list.and_groups (ag).cons (c).seek_head_sw = "1"b; end; /* operator is > or >= */ else if vrm_search_list.and_groups (ag).cons (c).operator < 4 then do; vrm_search_list.and_groups (ag).cons (c).seek_head_sw = "1"b; num_seek_head_attr = num_seek_head_attr + 1; end; /* operator is < or <= */ else if vrm_search_list.and_groups (ag).cons (c).operator > 5 then do; vrm_search_list.and_groups (ag).cons (c).and_group_search_terminator = "1"b; done_sw = "1"b; end; end; /* attribute in right position */ end; /* loop over all attributes */ if last_op_was_equal then do; if vrm_collection_info.unique & num_seek_head_attr = vrm_collection_info.number_of_attributes then vrm_search_list.and_groups (ag).full_key_equal_only_sw = "1"b; end; /* See if a bad key attribute exist in key_head One that cannot be character aligned */ if num_seek_head_attr < vrm_collection_info.number_of_attributes then do; done_sw = "0"b; do x = num_seek_head_attr to 1 by -1 while (^done_sw); /* if the next key attribute does not start on a character position, we must back up on */ if mod (vrm_collection_info.attribute (x + 1).key_offset, 9) ^= 0 then do; vrm_search_list.and_groups (ag).cons (x).seek_head_sw = "0"b; vrm_search_list.and_groups (ag).cons (x).and_group_search_terminator = "0"b; num_seek_head_attr = num_seek_head_attr - 1; end; else done_sw = "1"b; end; end; vrm_search_list.and_groups (ag).seek_key_con_ix = num_seek_head_attr; vrm_search_list.and_groups (ag).num_seek_key_attr_count = num_seek_head_attr; if num_seek_head_attr > 1 then do; vrm_search_list.and_groups (ag).multi_attr_seek_head_sw = "1"b; end; end optimize_and_group; /* * * * * * * * * * * * * switch_constraints * * * * * * * * * * */ switch_constraints: proc (con_1, con_2, switched_flag); /* This procedure switches constraint info with in an and group moving first constraint to seconds position and visa-versa */ dcl con_1 fixed bin parameter; /* First constraint */ dcl con_2 fixed bin parameter; /* Second constaint */ dcl switched_flag bit (1) aligned parameter; switched_flag = "1"b; temp_constraint_info = vrm_search_list.and_groups (ag).cons (con_1); vrm_search_list.and_groups (ag).cons (con_1) = vrm_search_list.and_groups (ag).cons (con_2); vrm_search_list.and_groups (ag).cons (con_2) = temp_constraint_info; end switch_constraints; /* * * * * * * * * * * * * * * * * * * error * * * * * * * * * * * * */ error: proc (cd); dcl cd fixed bin (35) parameter; O_code = cd; goto exit; end error; db_on: entry; db_sw = "1"b; return; db_off: entry; db_sw = "0"b; return; %include dm_operator_constants; %page; %include dm_relation_spec; %page; %include dm_specification_head; %page; %include vrm_search_list; %page; %include vrm_cursor; %page; %include vrm_open_info; %page; %include vrm_rel_desc; %page; %include vrm_collection_info; %page; %include vrm_meter; %page; %include vrm_com; %page; %include sub_err_flags; %page; dcl 1 temp_constraint_info like constraint_info aligned; dcl (KEEP_BOTH init (1), REMOVE_A init (2), REMOVE_B init (3), REMOVE_B_MAKE_A_EQUALS init (4), KILL_AND_GROUP init (5)) fixed bin internal static options (constant); dcl action fixed bin; dcl addr builtin; dcl addrel builtin; dcl ag fixed bin; dcl switched bit (1) aligned; dcl c fixed bin; dcl c1 fixed bin; dcl c2 fixed bin; dcl code fixed bin (35); dcl collection_id_found bit (1) aligned; dcl cx fixed bin; dcl db_sw bit (1) int static init ("0"b); dcl done_sw bit (1) aligned; dcl fixed builtin; dcl get_area area (sys_info$max_seg_size) based (vrm_com.get_seg_ptr); dcl i fixed bin; dcl key_attr_found bit (1) aligned; dcl key_head_attr_exists bit (1) aligned; dcl last_op_was_equal bit (1) aligned; dcl length builtin; dcl mod builtin; dcl mrds_error_$internal_error fixed bin (35) ext static; dcl null builtin; dcl num_search_keys_used fixed bin; dcl num_seek_head_attr fixed bin; dcl rel builtin; dcl RELATION_COLLECTION_ID bit (36) int static options (constant) init ("111111111111111111111111111111111111"b); dcl sub_err_ entry () options (variable); dcl sys_info$max_seg_size fixed bin (35) ext static; dcl unspec builtin; dcl vrmu_encode_key$encode_attr entry (ptr, ptr, char (*) var, fixed bin (35)); dcl vrmu_scan_records$scan_records_init entry (ptr, fixed bin (35)); dcl vrmu_validate_spec entry (ptr, ptr, fixed bin, fixed bin (35)); dcl vrm_display_search_list$subroutine entry (ptr); dcl x fixed bin; dcl key_cons_this_group fixed bin; dcl next_key_pos fixed bin; end vrmu_search_init;  vrmu_validate_spec.pl1 11/23/84 0800.9r w 11/21/84 0934.2 41490 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ vrmu_validate_spec: proc (I_vrm_cursor_ptr, I_spec_ptr, O_num_key_constraints, O_code); /* . BEGIN_DESCRIPTION The purpose of this module is to validate if the fields supplied in the search_specification are with the range of attributes for this relation. And to count the number of key_constraint fields used . END_DESCRIPTION */ /* HISTORY 82-08-30 Roger Lackey : Initially written. */ /* PARAMETERS */ dcl I_vrm_cursor_ptr ptr parameter; /* Pointer to vrm_cursor */ dcl I_spec_ptr ptr parameter; /* Pointer to dm_specification supplied */ dcl O_num_key_constraints fixed bin parameter; /* Number of constraints against the index for cursor supplied */ dcl O_code fixed bin (35) parameter; /* Error_code */ %page; /* vrmu_validate_spec: proc (I_vrm_cursor_ptr, I_spec_ptr, O_num_key_constraints, O_code); */ vrm_cursor_ptr = I_vrm_cursor_ptr; relation_search_specification_ptr = I_spec_ptr; O_num_key_constraints = 0; O_code = 0; rss_maximum_number_of_constraints = 0; /* Just to keep compile happy */ vrm_rel_desc_ptr = vrm_cursor.vrm_relation_desc_ptr; vrm_open_info_ptr = vrm_cursor.open_info_ptr; num_key_constraints = 0; if relation_search_specification_ptr ^= null () then do; if relation_search_specification.head.version ^= SPECIFICATION_VERSION_4 then do; O_code = dm_error_$unimplemented_spec_version; return; end; if relation_search_specification.head.type ^= ABSOLUTE_RELATION_SEARCH_SPECIFICATION_TYPE & relation_search_specification.head.type ^= RELATIVE_RELATION_SEARCH_SPECIFICATION_TYPE then do; O_code = dm_error_$unsup_search_spec_head_type; return; end; if relation_search_specification.range.type ^= ALL_RANGE_TYPE & relation_search_specification.range.type ^= LOW_RANGE_TYPE then do; O_code = dm_error_$unsup_search_spec_range_type; return; end; do ag = 1 to relation_search_specification.number_of_and_groups while (O_code = 0); if ^relation_search_specification.and_group (ag).collection_id_supplied then do; call sub_err_ (mrds_error_$internal_error, "vrmu_validate_spec", ACTION_CANT_RESTART, null, 0, "A relation_search_specification has been found without a collection_id supplied."); end; do c = 1 to relation_search_specification.and_group (ag).number_of_constraints while (O_code = 0); if relation_search_specification.and_group (ag).constraint (c).field_id < 1 | relation_search_specification.and_group (ag).constraint (c).field_id > vrm_rel_desc.number_attrs then O_code = dm_error_$invalid_specification_field; else if relation_search_specification.and_group (ag).constraint (c).value_ptr ^= null then do; opr = relation_search_specification.and_group (ag).constraint (c).operator_code; if opr < 1 | opr > 7 | opr = 4 then O_code = dm_error_$unsupported_spec_operator; x = relation_search_specification.and_group (ag).constraint (c).field_id; if vrm_rel_desc.attr (x).key_head | vrm_rel_desc.attr (x).primary_key_attr then num_key_constraints = num_key_constraints + 1; end; end; /* END do c = 1 to relation_search_specification.and_group (ag).number_of_constraints while (O_code = 0); */ end; end; O_num_key_constraints = num_key_constraints; %page; %include vrm_cursor; %page; %include vrm_collection_info; %page; %include vrm_rel_desc; %page; %include dm_specification_head; %page; %include dm_relation_spec; %page; %include dm_range_constants; %page; %include vrm_open_info; %page; %include sub_err_flags; %page; dcl dm_error_$invalid_specification_field fixed bin (35) ext static; dcl dm_error_$unimplemented_spec_version fixed bin (35) ext static; dcl dm_error_$unsupported_spec_operator fixed bin (35) ext static; dcl dm_error_$unsup_search_spec_range_type fixed bin (35) ext static; dcl dm_error_$unsup_search_spec_head_type fixed bin (35) ext static; dcl c fixed bin; dcl ag fixed bin; dcl mrds_error_$internal_error fixed bin (35) ext static; dcl null builtin; dcl num_key_constraints fixed bin; dcl opr fixed bin; dcl sub_err_ entry () options (variable); dcl x fixed bin; end vrmu_validate_spec; bull_copyright_notice.txt 08/30/05 1008.4r 08/30/05 1007.3 00020025 ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull and Bull HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by Bull HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved