



		    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 <REL_DESC>^/^7x-reset_meters^23t| -rsm <REL_DESC>^/^7x-print_meters^23t| -prm <REL_DESC>^/^7x-meter^23t| -mt  <REL_DESC>^/^7x-delete_meters^23t| -dlm <REL_DESC>^/");
%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
